Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge trunk |
|---|---|
| Timelines: | family | ancestors | descendants | both | apn-icu-testdata |
| Files: | files | file ages | folders |
| SHA3-256: |
a2841ef20b7ad8b012af88349e81e6ba |
| User & Date: | apnadkarni 2025-01-04 11:48:43.678 |
Context
|
2025-06-23
| ||
| 16:09 | Merge trunk check-in: 1c53e7c490 user: apnadkarni tags: apn-icu-testdata | |
|
2025-01-04
| ||
| 11:48 | Merge trunk check-in: a2841ef20b user: apnadkarni tags: apn-icu-testdata | |
|
2025-01-03
| ||
| 13:51 | Fix [afdb56e633]: Tcl_MethodType2 not documented check-in: 0a63898c7f user: jan.nijtmans tags: trunk, main | |
|
2024-02-19
| ||
| 15:16 | More ICU tests for SBCS encodings check-in: 28cbbdbe1e user: apnadkarni tags: apn-icu-testdata | |
Changes
Changes to .fossil-settings/crlf-glob.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | compat/zlib/win32/*.txt compat/zlib/win64/*.txt compat/zlib/zlib.map libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.wse.in | > | < < < < | 8 9 10 11 12 13 14 15 16 17 18 19 | compat/zlib/win32/*.txt compat/zlib/win64/*.txt compat/zlib/zlib.map libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.wse.in win/*.bat win/*.vc win/coffbase.txt win/tcl.dsp win/tcl.dsw |
Changes to .fossil-settings/ignore-glob.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.txt | > > | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist unix/pkgs8/* unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs8/* win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.txt |
Changes to .gitattributes.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | *.ts text *.tcl text *.test text # Declare files that will always have CRLF line endings on checkout. *.bat eol=crlf *.cs eol=crlf *.sln eol=crlf *.vc eol=crlf # Denote all files that are truly binary and should not be modified. *.a binary *.bmp binary *.dll binary | > > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | *.ts text *.tcl text *.test text # Declare files that will always have CRLF line endings on checkout. *.bat eol=crlf *.cs eol=crlf *.dsp eol=crlf *.dsw eol=crlf *.sln eol=crlf *.vc eol=crlf # Denote all files that are truly binary and should not be modified. *.a binary *.bmp binary *.dll binary |
| ︙ | ︙ |
Changes to .github/workflows/linux-build.yml.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
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: |
| | | > > > > | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
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 -j4 all
timeout-minutes: 5
- name: Build Test Harness
run: |
make -j4 tcltest
timeout-minutes: 5
- name: Info
run: |
ulimit -a || echo 'get limit failed'
echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed'
- name: Run Tests
run: |
make test
env:
ERROR_ON_FAILURES: 1
timeout-minutes: 30
- name: Test-Drive Installation
|
| ︙ | ︙ |
Changes to .github/workflows/mac-build.yml.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
name: macOS
on:
push:
branches:
- "main"
- "core-8-branch"
- "core-8-6-branch"
tags:
- "core-**"
permissions:
contents: read
jobs:
xcode:
| | | | | | 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 |
name: macOS
on:
push:
branches:
- "main"
- "core-8-branch"
- "core-8-6-branch"
tags:
- "core-**"
permissions:
contents: read
jobs:
xcode:
runs-on: macos-14
defaults:
run:
shell: bash
working-directory: macosx
steps:
- name: Checkout
uses: actions/checkout@v4
timeout-minutes: 5
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Build
run: make -j4 all
env:
CFLAGS: -arch x86_64 -arch arm64
timeout-minutes: 15
- name: Run Tests
run: make -j4 test styles=develop
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
timeout-minutes: 15
clang:
runs-on: macos-14
strategy:
matrix:
config:
- ""
- "--disable-shared"
- "--disable-zipfs"
- "--enable-symbols"
|
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
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: |
| | > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
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 -j4 all tcltest
env:
CFLAGS: -arch x86_64 -arch arm64
timeout-minutes: 15
- name: Info
run: |
ulimit -a || echo 'get limit failed'
echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed'
- name: Run Tests
run: |
make test
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
timeout-minutes: 15
|
Changes to .github/workflows/onefiledist.yml.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
working-directory: unix
- 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
| > > > > > > > | | 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 |
working-directory: unix
- 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: Info
run: |
ulimit -a || echo 'get limit failed'
echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed'
- name: Upload
uses: actions/upload-artifact@v4
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot)
path: 1dist/*.tar
id: upload
outputs:
url: ${{ steps.upload.outputs.artifact-url }}
macos:
name: macOS
runs-on: macos-13
defaults:
run:
shell: bash
timeout-minutes: 10
steps:
- name: Checkout
uses: actions/checkout@v4
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
echo "CREATE_DMG=$(cd create-dmg;pwd)/create-dmg" >> $GITHUB_ENV
echo "CFLAGS=-arch x86_64 -arch arm64" >> $GITHUB_ENV
- name: Configure
run: ./configure --disable-symbols --disable-shared --enable-zipfs
working-directory: unix
- name: Build
run: |
| | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
echo "CREATE_DMG=$(cd create-dmg;pwd)/create-dmg" >> $GITHUB_ENV
echo "CFLAGS=-arch x86_64 -arch arm64" >> $GITHUB_ENV
- name: Configure
run: ./configure --disable-symbols --disable-shared --enable-zipfs
working-directory: unix
- name: Build
run: |
make -j4 tclsh
make -j4 shell SCRIPT="$VER_PATH $GITHUB_ENV"
echo "TCL_BIN=`pwd`/tclsh" >> $GITHUB_ENV
echo "TCL_ZIP=`pwd`/`echo libtcl*.zip`" >> $GITHUB_ENV
working-directory: unix
- name: Package
run: |
mkdir contents
cp $TCL_BIN contents/tclsh${TCL_PATCHLEVEL}_snapshot
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
$CREATE_DMG \
--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:
run:
shell: msys2 {0}
timeout-minutes: 10
| > > > > > > > | 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 |
$CREATE_DMG \
--volname "Tcl $TCL_PATCHLEVEL (snapshot)" \
--window-pos 200 120 \
--window-size 800 400 \
"Tcl-$TCL_PATCHLEVEL-(snapshot).dmg" \
"contents/"
working-directory: 1dist
- name: Info
run: |
ulimit -a || echo 'get limit failed'
echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed'
- name: Upload
uses: actions/upload-artifact@v4
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot)
path: 1dist/*.dmg
id: upload
outputs:
url: ${{ steps.upload.outputs.artifact-url }}
win:
name: Windows
runs-on: windows-2019
defaults:
run:
shell: msys2 {0}
timeout-minutes: 10
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 154 155 |
run: |
./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'
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
run: |
./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: Info
run: |
ulimit -a || echo 'get limit failed'
echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed'
- name: Upload
uses: actions/upload-artifact@v4
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot)
path: '1dist/*_snapshot.exe'
id: upload
outputs:
url: ${{ steps.upload.outputs.artifact-url }}
combine:
needs:
- linux
- macos
- win
name: Combine Artifacts (prototype)
runs-on: ubuntu-latest
defaults:
run:
shell: bash
timeout-minutes: 10
env:
# See also
# https://docs.github.com/en/actions/writing-workflows/choosing-what-your-workflow-does/store-information-in-variables
REMOTE_PATH: ${{ vars.PUBLISH_DROP_PATH }}/data-${{ github.sha }}
steps:
- name: Make directory
run: |
mkdir data
- name: Get Linux build
uses: actions/download-artifact@v4
with:
path: data
# Can't download by artifact ID; stupid missing feature!
merge-multiple: true
- name: Check data downloaded
run: |
ls -AlR
working-directory: data
- name: Transfer built files
# https://github.com/marketplace/actions/rsync-deployments-action
uses: burnett01/rsync-deployments@7.0.1
id: rsync
if: false # Disabled... for now
with:
# I don't know what the right switches are here, BTW
switches: -avzr
path: data/
remote_path: ${{ env.REMOTE_PATH }}
remote_host: ${{ vars.PUBLISH_HOST }}
remote_user: ${{ vars.PUBLISH_USER }}
remote_key: ${{ secrets.DEPLOY_HOST_KEY }}
# MUST be a literal passwordless key
- name: Publish files
# https://github.com/marketplace/actions/ssh-remote-commands
uses: appleboy/ssh-action@v1.2.0
id: ssh
if: steps.rsync.outcome == 'success'
with:
host: ${{ vars.PUBLISH_HOST }}
username: ${{ vars.PUBLISH_USER }}
key: ${{ secrets.DEPLOY_HOST_KEY }}
script: |
${{ vars.PUBLISHER_SCRIPT }} ${{ env.REMOTE_PATH }} ${{ github.ref_type }} ${{ github.ref_name }}
- name: Report what would be done
if: steps.rsync.outcome == 'skipped'
env:
SWITCHES: -av
LOCAL_PATH: data/
REMOTE_HOST: ${{ vars.PUBLISH_HOST }}
REMOTE_USER: ${{ vars.PUBLISH_USER }}
REMOTE_SCRIPT: |
${{ vars.PUBLISHER_SCRIPT }} ${{ env.REMOTE_PATH }} ${{ github.ref_type }} ${{ github.ref_name }}
run: |
echo "would run: rsync $SWITCHES $LOCAL_PATH $REMOTE_USER@$REMOTE_HOST:$REMOTE_PATH"
echo "would run: ssh $REMOTE_USER@$REMOTE_HOST $REMOTE_SCRIPT"
# Consider https://github.com/marketplace/actions/slack-notify maybe?
|
Changes to .github/workflows/win-build.yml.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
- 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
| | | > > > > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
- 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 -j4 all
timeout-minutes: 5
- name: Build Test Harness
run: make -j4 tcltest
timeout-minutes: 5
- name: Info
run: |
ulimit -a || echo 'get limit failed'
echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed'
- 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 .gitignore.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/embtest unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.txt | > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/embtest unix/tcl.pc unix/tclIndex unix/pkgs8/* unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs8/* win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.txt |
Deleted .travis.yml.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to README.md.
1 2 | # README: Tcl | | | | | | | | | | < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # README: Tcl This is the **Tcl 9.0.2** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). 9.0 (production release, daily build) [](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Amain) [](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Amain) [](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Amain) <br> 8.7 (in development, daily build) [](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Acore-8-branch) [](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Acore-8-branch) [](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Acore-8-branch) ## Contents 1. [Introduction](#intro) 2. [Documentation](#doc) 3. [Compiling and installing Tcl](#build) 4. [Development tools](#devtools) 5. [Tcl newsgroup](#complangtcl) |
| ︙ | ︙ |
Deleted changes.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added changes.md.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
The source code for Tcl is managed by fossil. Tcl developers coordinate all
changes to the Tcl source code at
> [Tcl Source Code](https://core.tcl-lang.org/tcl/timeline)
Release Tcl 9.0.1 arises from the check-in with tag `core-9-0-1`.
Tcl patch releases have the primary purpose of delivering bug fixes
to the userbase. As the first patch release in the Tcl 9.0.\* series,
Tcl 9.0.1 also includes a small number of interface changes that complete
some incomplete features first delivered in Tcl 9.0.0.
# Completed 9.0 Features and Interfaces
- [TIP 701 - Tcl_FSTildeExpand C API](https://core.tcl-lang.org/tips/doc/trunk/tip/701.md)
- [TIP 707 - ptrAndSize internal rep in Tcl_Obj](https://core.tcl-lang.org/tips/doc/trunk/tip/707.md)
- [Size modifiers j, q, z, t not implemented]( https://core.tcl-lang.org/tcl/info/c4f365)
# Bug fixes
- [regression in tzdata, %z instead of offset TZ-name](https://core.tcl-lang.org/tcl/tktview/2c237b)
- [Tcl will not start properly if there is an init.tcl file in the current dir](https://core.tcl-lang.org/tcl/tktview/43c94f)
- [clock scan "24:00", ISO-8601 compatibility](https://core.tcl-lang.org/tcl/tktview/aee9f2)
- [Temporary folder with file "tcl9registry13.dll" remains after "exit"](https://core.tcl-lang.org/tcl/tktview/6ce3c0)
- [Wrong result by "lsearch -stride -subindices -inline -all"](https://core.tcl-lang.org/tcl/info/5a1aaa)
- [TIP 609 - required Tcl_ThreadAlert() skipped with nested event loop](https://core.tcl-lang.org/tcl/info/c7e4c4)
- [buffer overwrite for non-BMP characters in utf-16](https://core.tcl-lang.org/tcl/tktview/66da4d)
- [zipfs info on mountpoint of executable returns zero offset in field 4"](https://core.tcl-lang.org/tcl/info/aaa84f)
- [zlib-8.8, zlib-8.16 fail on Fedora 40, gcc 14.1.1](https://core.tcl-lang.org/tcl/tktview/73d5cb)
- [install registry and dde in $INSTALL_DIR\lib always](https://core.tcl-lang.org/tcl/tktview/364bd9)
- [cannot build .chm help file (Windows)](https://core.tcl-lang.org/tcl/tktview/bb110c)
# Incompatibilities
- No known incompatibilities with the Tcl 9.0.0 public interface.
# Updated bundled packages, libraries, standards, data
- Itcl 4.3.2
- sqlite3 3.47.2
- Thread 3.0.1
- TDBC\* 1.1.10
- tcltest 2.5.9
- tzdata 2024b, corrected
Release Tcl 9.0.0 arises from the check-in with tag `core-9-0-0`.
Highlighted differences between Tcl 9.0 and Tcl 8.6 are summarized below,
with focus on changes important to programmers using the Tcl library and
writing Tcl scripts.
# Major Features
## 64-bit capacity: Data values larger than 2Gb
- Strings can be any length (that fits in your available memory)
- Lists and dictionaries can have very large numbers of elements
## Internationalization of text
- Full Unicode range of codepoints
- New encodings: `utf-16`/`utf-32`/`ucs-2`(`le`|`be`), `CESU-8`, etc.
- `encoding` options `-profile`, `-failindex` manage encoding of I/O.
- `msgcat` supports custom locale search list
- `source` defaults to `-encoding utf-8`
## Zip filesystems and attached archives.
- Packaging of the Tcl script library with the Tcl binary library,
meaning that the `TCL_LIBRARY` environment variable is usually not required.
- Packaging of an application into a virtual filesystem is now a supported
core Tcl feature.
## Unix notifiers available using `epoll()` or `kqueue()`
- This relieves limits on file descriptors imposed by legacy `select()` and fixes a performance bottleneck.
# Incompatibilities
## Notable incompatibilities
- Unqualified varnames resolved in current namespace, not global.
Note that in almost all cases where this causes a change, the change is actually the removal of a latent bug.
- No `--disable-threads` build option. Always thread-enabled.
- I/O malencoding default response: raise error (`-profile strict`)
- Windows platform needs Windows 7 or Windows Server 2008 R2 or later
- Ended interpretation of `~` as home directory in pathnames.
(See `file home` and `file tildeexpand` for replacements when you need them.)
- Removed the `identity` encoding.
(There were only ever very few valid use cases for this; almost all uses
were systematically wrong.)
- Removed the encoding alias `binary` to `iso8859-1`.
- `$::tcl_precision` no longer controls string generation of doubles.
(If you need a particular precision, use `format`.)
- Removed pre-Tcl 8 legacies: `case`, `puts` and `read` variant syntaxes.
- Removed subcommands [`trace variable`|`vdelete`|`vinfo`]
- Removed `-eofchar` option for write channels.
- On Windows 10+ (Version 1903 or higher), system encoding is always utf-8.
- `%b`/`%d`/`%o`/`%x` format modifiers (without size modifier) for `format`
and `scan` always truncate to 32-bits on all platforms.
- `%L` size modifier for `scan` no longer truncates to 64-bit.
- Removed command `::tcl::unsupported::inject`.
(See `coroinject` and `coroprobe` for supported commands with significantly
more comprehensible semantics.)
## Incompatibilities in C public interface
- Extensions built against Tcl 8.6 and before will not work with Tcl 9.0;
ABI compatibility was a non-goal for 9.0. In _most_ cases, rebuilding
against Tcl 9.0 should work except when a removed API function is used.
- Many arguments expanded type from `int` to `Tcl_Size`, a signed integer type
large enough to support 64-bit sized memory objects.
The constant `TCL_AUTO_LENGTH` is a value of that type that indicates that
the length should be obtained using an appropriate function (typically `strlen()` for `char *` values).
- Ended support for `Tcl_ChannelTypeVersion` less than 5
- Introduced versioning of the `Tcl_ObjType` struct
- Removed macros `CONST*`: Tcl 9 support means dropping Tcl 8.3 support.
(Replaced with standard C `const` keyword going forward.)
- Removed registration of several `Tcl_ObjType`s.
- Removed API functions:
`Tcl_Backslash()`,
`Tcl_*VA()`,
`Tcl_*MathFunc*()`,
`Tcl_MakeSafe()`,
`Tcl_(Save|Restore|Discard|Free)Result()`,
`Tcl_EvalTokens()`,
`Tcl_(Get|Set)DefaultEncodingDir()`,
`Tcl_UniCharN(case)cmp()`,
`Tcl_UniCharCaseMatch()`
- Revised many internals; beware reliance on undocumented behaviors.
# New Features
## New commands
- `array default` — Specify default values for arrays (note that this alters the behaviour of `append`, `incr`, `lappend`).
- `array for` — Cheap iteration over an array's contents.
- `chan isbinary` — Test if a channel is configured to work with binary data.
- `coroinject`, `coroprobe` — Interact with paused coroutines.
- `clock add weekdays` — Clock arithmetic with week days.
- `const`, `info const*` — Commands for defining constants (variables that can't be modified).
- `dict getwithdefault` — Define a fallback value to use when `dict get` would otherwise fail.
- `file home` — Get the user home directory.
- `file tempdir` — Create a temporary directory.
- `file tildeexpand` — Expand a file path containing a `~`.
- `info commandtype` — Introspection for the kinds of commands.
- `ledit` — Equivalent to `lreplace` but on a list in a variable.
- `lpop` — Remove an item from a list in a variable.
- `lremove` — Remove a sublist from a list in a variable.
- `lseq` — Generate a list of numbers in a sequence.
- `package files` — Describe the contents of a package.
- `string insert` — Insert a string as a substring of another string.
- `string is dict` — Test whether a string is a dictionary.
- `tcl::process` — Commands for working with subprocesses.
- `*::build-info` — Obtain information about the build of Tcl.
- `readFile`, `writeFile`, `foreachLine` — Simple procedures for basic working with files.
- `tcl::idna::*` — Commands for working with encoded DNS names.
## New command options
- `chan configure ... -inputmode ...` — Support for raw terminal input and reading passwords.
- `clock scan ... -validate ...`
- `info loaded ... ?prefix?`
- `lsearch ... -stride ...` — Search a list by groups of items.
- `regsub ... -command ...` — Generate the replacement for a regular expression by calling a command.
- `socket ... -nodelay ... -keepalive ...`
- `vwait` controlled by several new options
- `expr` string comparators `lt`, `gt`, `le`, `ge`
- `expr` supports comments inside expressions
## Numbers
- <code>0<i>NNN</i></code> format is no longer octal interpretation. Use <code>0o<i>NNN</i></code>.
- <code>0d<i>NNNN</i></code> format to compel decimal interpretation.
- <code>NN_NNN_NNN</code>, underscores in numbers for optional readability
- Functions: `isinf()`, `isnan()`, `isnormal()`, `issubnormal()`, `isunordered()`
- Command: `fpclassify`
- Function `int()` no longer truncates to word size
## TclOO facilities
- private variables and methods
- class variables and methods
- abstract and singleton classes
- configurable properties
- `method -export`, `method -unexport`
# Known bugs
- [changed behaviour wrt command names, namespaces and resolution](https://core.tcl-lang.org/tcl/tktview/f14b33)
- [windows dos device paths inconsistencies and missing functionality](https://core.tcl-lang.org/tcl/tktview/d8f121)
- [load library (dll) from zipfs-library causes a leak in temporary folder](https://core.tcl-lang.org/tcl/tktview/a8e4f7)
- [lsearch -sorted -inline -subindices incorrect result](https://core.tcl-lang.org/tcl/tktview/bc4ac0)
- ["No error" when load fails due to a missing secondary DLL](https://core.tcl-lang.org/tcl/tktview/bc4ac0)
|
Changes to compat/fake-rfc2553.c.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
TCL_DECLARE_MUTEX(netdbMutex)
#ifndef HAVE_GETNAMEINFO
#ifndef HAVE_STRLCPY
static size_t
strlcpy(char *dst, const char *src, size_t siz)
{
| | | | | | | | | | | | | | | | | | | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
TCL_DECLARE_MUTEX(netdbMutex)
#ifndef HAVE_GETNAMEINFO
#ifndef HAVE_STRLCPY
static size_t
strlcpy(char *dst, const char *src, size_t siz)
{
char *d = dst;
const char *s = src;
size_t n = siz;
/* Copy as many bytes as will fit */
if (n != 0 && --n != 0) {
do {
if ((*d++ = *s++) == 0)
break;
} while (--n != 0);
}
/* Not enough room in dst, add NUL and traverse rest of src */
if (n == 0) {
if (siz != 0)
*d = '\0'; /* NUL-terminate dst */
while (*s++)
;
}
return(s - src - 1); /* count does not include NUL */
}
#endif
int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host,
size_t hostlen, char *serv, size_t servlen, int flags)
{
struct sockaddr_in *sin = (struct sockaddr_in *)sa;
struct hostent *hp;
char tmpserv[16];
(void)salen;
if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET)
|
| ︙ | ︙ |
Deleted compat/string.h.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to doc/Access.3.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | file exists and has read, write and execute permissions, respectively. \fBF_OK\fR just requests a check for the existence of the file. .AP "struct stat" *statPtr out The structure that contains the result. .BE .SH DESCRIPTION .PP | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | file exists and has read, write and execute permissions, respectively. \fBF_OK\fR just requests a check for the existence of the file. .AP "struct stat" *statPtr out The structure that contains the result. .BE .SH DESCRIPTION .PP The object-based APIs \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR should be used in preference to \fBTcl_Access\fR and \fBTcl_Stat\fR, wherever possible. Those functions also support Tcl's virtual filesystem layer, which these do not. .SS "OBSOLETE FUNCTIONS" .PP There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather than calling system level functions \fBaccess\fR and \fBstat\fR directly. |
| ︙ | ︙ |
Changes to doc/AddErrInfo.3.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *)NULL\fR) .sp int \fBTcl_GetErrorLine\fR(\fIinterp\fR) .sp \fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) .sp const char * |
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in The \fB\-errorcode\fR return option will be set to this value. .AP "const char" *element in String to record as one element of the \fB\-errorcode\fR return option. | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in The \fB\-errorcode\fR return option will be set to this value. .AP "const char" *element in String to record as one element of the \fB\-errorcode\fR return option. Last \fIelement\fR argument must be (char *)NULL. .AP int lineNum The line number of a script where an error occurred. .AP "const char" *script in Pointer to first character in script containing command (must be <= \fIcommand\fR). .AP "const char" *command in Pointer to first character in the command that generated the error; must |
| ︙ | ︙ |
Changes to doc/Alloc.3.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void * \fBTcl_Alloc\fR(\fIsize\fR) .sp \fBTcl_Free\fR(\fIptr\fR) .sp void * \fBTcl_Realloc\fR(\fIptr, size\fR) .sp void * \fBTcl_AttemptAlloc\fR(\fIsize\fR) .sp void * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) .sp \fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR) .fi .SH ARGUMENTS .AS char *size .AP "size_t" size in Size in bytes of the memory block to allocate. .AP void *ptr in Pointer to memory block to free or realloc. .AP Tcl_DString *dsPtr in Initialized DString pointer. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ |
Changes to doc/Async.3.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_AsyncHandler \fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) .sp \fBTcl_AsyncMark\fR(\fIasync\fR) .sp int \fBTcl_AsyncMarkFromSignal\fR(\fIasync\fR, \fIsigNumber\fR) .sp int \fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) .sp \fBTcl_AsyncDelete\fR(\fIasync\fR) .sp int \fBTcl_AsyncReady\fR() .fi .SH ARGUMENTS .AS Tcl_AsyncHandler clientData | > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_AsyncHandler \fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) .sp void \fBTcl_AsyncMark\fR(\fIasync\fR) .sp int \fBTcl_AsyncMarkFromSignal\fR(\fIasync\fR, \fIsigNumber\fR) .sp int \fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) .sp void \fBTcl_AsyncDelete\fR(\fIasync\fR) .sp int \fBTcl_AsyncReady\fR() .fi .SH ARGUMENTS .AS Tcl_AsyncHandler clientData |
| ︙ | ︙ |
Changes to doc/ByteArrObj.3.
| ︙ | ︙ | |||
140 141 142 143 144 145 146 | \fBTcl_Size\fR or of type \fBint\fR. It is recommended that callers provide a \fBTcl_Size\fR space for this purpose. If the caller provides only an \fBint\fR space and the number of bytes in the byte-array value of \fIobjPtr\fR is greater than \fBINT_MAX\fR, the routine will fail due to being unable to correctly report the byte-array size to the caller. The ability to provide an \fBint\fR space is best considered a migration aid for codebases constrained to continue operating with Tcl releases | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | \fBTcl_Size\fR or of type \fBint\fR. It is recommended that callers provide a \fBTcl_Size\fR space for this purpose. If the caller provides only an \fBint\fR space and the number of bytes in the byte-array value of \fIobjPtr\fR is greater than \fBINT_MAX\fR, the routine will fail due to being unable to correctly report the byte-array size to the caller. The ability to provide an \fBint\fR space is best considered a migration aid for codebases constrained to continue operating with Tcl releases older than 9.0. .PP \fBTcl_SetByteArrayLength\fR enables a caller to change the size of a byte-array in the internal representation of an unshared \fIobjPtr\fR to become \fInumBytes\fR bytes. This is most often useful after the bytes of the internal byte-array have been directly overwritten and it has been discovered that the required size differs from the first estimate used in the allocation. \fBTcl_SetByteArrayLength\fR returns |
| ︙ | ︙ |
Changes to doc/ChnlStack.3.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | \fBTcl_GetTopChannel\fR returns the top channel in the stack of channels the supplied channel is part of. .PP \fBTcl_GetStackedChannel\fR returns the channel in the stack of channels which is just below the supplied channel. .SH "SEE ALSO" | | | 83 84 85 86 87 88 89 90 91 92 93 | \fBTcl_GetTopChannel\fR returns the top channel in the stack of channels the supplied channel is part of. .PP \fBTcl_GetStackedChannel\fR returns the channel in the stack of channels which is just below the supplied channel. .SH "SEE ALSO" Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n) .SH KEYWORDS channel, compression |
Changes to doc/CrtAlias.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_IsSafe, Tcl_CreateChild, Tcl_GetChild, Tcl_GetParent, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_IsSafe\fR(\fIinterp\fR) .sp |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
argc, argv\fR)
.sp
int
\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
objc, objv\fR)
.sp
| < < < < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
argc, argv\fR)
.sp
int
\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
objc, objv\fR)
.sp
int
\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr,
objcPtr, objvPtr\fR)
.sp
int
\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR)
.sp
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target command is defined for an alias. .AP "const char" **targetCmdPtr out Pointer to location to store the address of the name of the target command for an alias. | | | | | | < | < | < | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target command is defined for an alias. .AP "const char" **targetCmdPtr out Pointer to location to store the address of the name of the target command for an alias. .AP "Tcl_Size \&| int" *objcPtr out Pointer to location to store count of additional value arguments to be passed to the alias. The location is in storage owned by the caller. 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 aliases with more than INT_MAX value arguments, otherwise expect it to crash .AP Tcl_Obj ***objvPtr out Pointer to location to store a vector of Tcl_Obj structures, the additional arguments to pass to an alias command. The location is in storage owned by the caller, the vector of Tcl_Obj structures is owned by the called function. .AP "const char" *cmdName in Name of an exposed command to hide or create. |
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | \fItargetInterp\fR. Any two interpreters can be used, without any restrictions on how they are related. .PP \fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except that it takes a vector of values to pass as additional arguments instead of a vector of strings. .PP | > | | < < < < | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | \fItargetInterp\fR. Any two interpreters can be used, without any restrictions on how they are related. .PP \fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except that it takes a vector of values to pass as additional arguments instead of a vector of strings. .PP \fBTcl_GetAliasObj\fR returns information in the form of a pointer to a vector of Tcl_Obj structures about an alias \fIaliasName\fR in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in which case the corresponding datum is not returned. If a result field is non\-\fBNULL\fR, the address indicated is set to the corresponding datum. For example, if \fItargetCmdPtr\fR is non\-\fBNULL\fR it is set to a pointer to the string containing the name of the target command. .PP \fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from the set of hidden commands to the set of exposed commands, putting it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message as the result of \fIinterp\fR. |
| ︙ | ︙ |
Changes to doc/CrtChnlHdlr.3.
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | example, if there are two handlers for \fBTCL_READABLE\fR on the same channel, the first handler could consume all of the available input so that the channel is no longer readable when the second handler is invoked. For this reason it may be useful to use nonblocking I/O on channels for which there are event handlers. .SH "SEE ALSO" | | | | 77 78 79 80 81 82 83 84 85 86 | example, if there are two handlers for \fBTCL_READABLE\fR on the same channel, the first handler could consume all of the available input so that the channel is no longer readable when the second handler is invoked. For this reason it may be useful to use nonblocking I/O on channels for which there are event handlers. .SH "SEE ALSO" Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n) .SH KEYWORDS blocking, callback, channel, events, handler, nonblocking |
Changes to doc/CrtCommand.3.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | point to constant strings or may be shared with other parts of the interpreter. Note also that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. .PP \fIProc\fR must return an integer code that is expected to be one of \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or | | > | > > | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | point to constant strings or may be shared with other parts of the interpreter. Note also that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. .PP \fIProc\fR must return an integer code that is expected to be one of \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the \fBreturn\fR man page for details on what these codes mean and the use of extended values for an extension's private use. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. .PP In addition, \fIproc\fR must set the interpreter result; in the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR it gives an error message. The \fBTcl_SetResult\fR procedure provides an easy interface for setting the return value; for complete details on how the interpreter result field is managed, see the \fBTcl_Interp\fR man page. Before invoking a command procedure, |
| ︙ | ︙ |
Changes to doc/CrtObjCmd.3.
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that value; that call may change the type of the value that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. | < | > | > | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that value; that call may change the type of the value that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the \fBreturn\fR man page for details on what these codes mean and the use of extended values for an extension's private use. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. .PP In addition, if \fIproc\fR needs to return a non-empty result, it can call \fBTcl_SetObjResult\fR to set the interpreter's result. In the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR this gives an error message. Before invoking a command procedure, \fBTcl_EvalObjEx\fR sets interpreter's result to |
| ︙ | ︙ |
Changes to doc/Encoding.3.
| ︙ | ︙ | |||
249 250 251 252 253 254 255 | The last few bytes in the source buffer were the beginning of a multibyte sequence, but more bytes were needed to complete this sequence. A subsequent call to the conversion routine should pass a buffer containing the unconverted bytes that remained in \fIsrc\fR plus some further bytes from the source stream to properly convert the formerly split-up multibyte sequence. .IP \fBTCL_CONVERT_SYNTAX\fR 29 | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | The last few bytes in the source buffer were the beginning of a multibyte sequence, but more bytes were needed to complete this sequence. A subsequent call to the conversion routine should pass a buffer containing the unconverted bytes that remained in \fIsrc\fR plus some further bytes from the source stream to properly convert the formerly split-up multibyte sequence. .IP \fBTCL_CONVERT_SYNTAX\fR 29 The source buffer contained an invalid byte or character sequence. This may occur if the input stream has been damaged or if the input encoding method was misidentified. .IP \fBTCL_CONVERT_UNKNOWN\fR 29 The source buffer contained a character that could not be represented in the target encoding. .RE .LP |
| ︙ | ︙ |
Changes to doc/Eval.3.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *)NULL\fR) .fi .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in |
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies the interpreter result in the same way as \fBTcl_Eval\fR. | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies the interpreter result in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be (char *)NULL to indicate the end of arguments. .SH "FLAG BITS" .PP Any OR'ed combination of the following values may be used for the \fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR: .TP 23 |
| ︙ | ︙ |
Changes to doc/FileSystem.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2001 Vincent Darley '\" Copyright (c) 2008-2010 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 Filesystem 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2001 Vincent Darley '\" Copyright (c) 2008-2010 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 Filesystem 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSUnloadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_GetAccessTimeFromStat, Tcl_GetBlockSizeFromStat, Tcl_GetBlocksFromStat, Tcl_GetChangeTimeFromStat, Tcl_GetDeviceTypeFromStat, Tcl_GetFSDeviceFromStat, Tcl_GetFSInodeFromStat, Tcl_GetGroupIdFromStat, Tcl_GetLinkCountFromStat, Tcl_GetModeFromStat, Tcl_GetModificationTimeFromStat, Tcl_GetSizeFromStat, Tcl_GetUserIdFromStat, Tcl_AllocStatBuf, Tcl_FSTildeExpand \- procedures to interact with any filesystem .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR) .sp |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 143 144 145 146 147 148 149 | .sp const void * \fBTcl_FSGetNativePath\fR(\fIpathPtr\fR) .sp Tcl_Obj * \fBTcl_FSFileSystemInfo\fR(\fIpathPtr\fR) .sp Tcl_StatBuf * \fBTcl_AllocStatBuf\fR() .sp long long \fBTcl_GetAccessTimeFromStat\fR(\fIstatPtr\fR) .sp unsigned | > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | .sp const void * \fBTcl_FSGetNativePath\fR(\fIpathPtr\fR) .sp Tcl_Obj * \fBTcl_FSFileSystemInfo\fR(\fIpathPtr\fR) .sp int \fBTcl_FSTildeExpand\fR(\fIinterp, pathStr, dsPtr\fR) .sp Tcl_StatBuf * \fBTcl_AllocStatBuf\fR() .sp long long \fBTcl_GetAccessTimeFromStat\fR(\fIstatPtr\fR) .sp unsigned |
| ︙ | ︙ | |||
183 184 185 186 187 188 189 190 191 192 193 194 195 196 | \fBTcl_GetUserIdFromStat\fR(\fIstatPtr\fR) .fi .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in The path represented by this value is used for the operation in question. If the value does not already have an internal \fBpath\fR representation, it will be converted to have one. .AP Tcl_Obj *srcPathPtr in As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. | > > | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | \fBTcl_GetUserIdFromStat\fR(\fIstatPtr\fR) .fi .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP "const char" *pathStr in Pointer to a NUL terminated string representing a file system path. .AP Tcl_Obj *pathPtr in The path represented by this value is used for the operation in question. If the value does not already have an internal \fBpath\fR representation, it will be converted to have one. .AP Tcl_Obj *srcPathPtr in As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. |
| ︙ | ︙ | |||
289 290 291 292 293 294 295 296 297 298 299 300 301 302 | the symbolic link specified by \fIlinkNamePtr\fR is to be read. .AP int linkAction in OR-ed combination of flags indicating what kind of link should be created (will be ignored if \fItoPtr\fR is NULL). Valid bits to set are \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. When both flags are set and the underlying filesystem can do either, symbolic links are preferred. .BE .SH DESCRIPTION .PP There are several reasons for calling the \fBTcl_FS\fR API functions (e.g.\ \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR) rather than calling system level functions like \fBaccess\fR and \fBstat\fR directly. First, they will work cross-platform, so an | > > | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | the symbolic link specified by \fIlinkNamePtr\fR is to be read. .AP int linkAction in OR-ed combination of flags indicating what kind of link should be created (will be ignored if \fItoPtr\fR is NULL). Valid bits to set are \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. When both flags are set and the underlying filesystem can do either, symbolic links are preferred. .AP Tcl_DString *dsPtr out Pointer to a \fBTcl_DString\fR to hold an output string result. .BE .SH DESCRIPTION .PP There are several reasons for calling the \fBTcl_FS\fR API functions (e.g.\ \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR) rather than calling system level functions like \fBaccess\fR and \fBstat\fR directly. First, they will work cross-platform, so an |
| ︙ | ︙ | |||
731 732 733 734 735 736 737 | a UTF-8 string representation if that is required by some Tcl code. .PP \fBTcl_FSGetNativePath\fR is for use by the Win/Unix native filesystems, so that they can easily retrieve the native (char* or TCHAR*) representation of a path. This function is a convenience wrapper around \fBTcl_FSGetInternalRep\fR. It may be desirable in the future to have non-string-based native representations (for example, | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 | a UTF-8 string representation if that is required by some Tcl code. .PP \fBTcl_FSGetNativePath\fR is for use by the Win/Unix native filesystems, so that they can easily retrieve the native (char* or TCHAR*) representation of a path. This function is a convenience wrapper around \fBTcl_FSGetInternalRep\fR. It may be desirable in the future to have non-string-based native representations (for example, on macOS, a representation using a fileSpec of FSRef structure would probably be more efficient). On Windows a full Unicode representation would allow for paths of unlimited length. Currently the representation is simply a character string which may contain either the relative path or a complete, absolute normalized path in the native encoding (complex conditions dictate which of these will be provided, so neither can be relied upon, unless the path is known to be absolute). If you need a native path which must be absolute, then you should ask for the native |
| ︙ | ︙ | |||
775 776 777 778 779 780 781 782 783 784 785 786 787 788 | .PP \fBTcl_FSGetPathType\fR determines whether the given path is relative to the current directory, relative to the current volume, or absolute. .PP It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR .SS "PORTABLE STAT RESULT API" .PP \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which may be deallocated by being passed to \fBTcl_Free\fR). This allows extensions to invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the size of the buffer. That in turn depends on the flags used to build Tcl. .PP | > > > > > > > > > > > | 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 | .PP \fBTcl_FSGetPathType\fR determines whether the given path is relative to the current directory, relative to the current volume, or absolute. .PP It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR .PP \fBTcl_FSTildeExpand\fR performs tilde substitution on the input path passed via \fBpathStr\fR as described in the documentation for the \fBfile tildeexpand\fR Tcl command. On success, the function returns \fBTCL_OK\fR with the result of the substitution in \fBdsPtr\fR which must be subsequently freed by the caller. The \fBdsPtr\fR structure is initialized by the function. No guarantees are made about the form of the returned path such as the path separators used. The returned result should be passed to other Tcl C API functions such as \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR if necessary. On error, the function returns \fBTCL_ERROR\fR with an error message in \fBinterp\fR which may be passed as NULL if error messages are not of interest. .SS "PORTABLE STAT RESULT API" .PP \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which may be deallocated by being passed to \fBTcl_Free\fR). This allows extensions to invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the size of the buffer. That in turn depends on the flags used to build Tcl. .PP |
| ︙ | ︙ |
Changes to doc/InitSubSyst.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 2018 Tcl Core Team '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 2018 Tcl Core Team '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_InitSubsystems 3 9.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_InitSubsystems \- initialize the Tcl library. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp |
| ︙ | ︙ |
Changes to doc/IntObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_NewWideUIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_SetWideUIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetSizeIntFromObj, Tcl_GetWideIntFromObj, Tcl_GetWideUIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewIntObj\fR(\fIintValue\fR) .sp Tcl_Obj * \fBTcl_NewLongObj\fR(\fIlongValue\fR) .sp Tcl_Obj * \fBTcl_NewWideIntObj\fR(\fIwideValue\fR) .sp Tcl_Obj * \fBTcl_NewWideUIntObj\fR(\fIuwideValue\fR) .sp \fBTcl_SetIntObj\fR(\fIobjPtr, intValue\fR) .sp \fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR) .sp \fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR) .sp \fBTcl_SetWideUIntObj\fR(\fIobjPtr, uwideValue\fR) .sp int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int \fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, indexPtr\fR) .sp |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | \fBTcl_GetIntForIndex\fR will return this when the input value is "end". .AP int intValue in Integer value used to initialize or set a Tcl value. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in Wide integer value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR, this points to the value in which to store an integral value. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR, this refers to the value from which to retrieve an integral value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when integral value | > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | \fBTcl_GetIntForIndex\fR will return this when the input value is "end". .AP int intValue in Integer value used to initialize or set a Tcl value. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in Wide integer value used to initialize or set a Tcl value. .AP Tcl_WideUInt uwideValue in Unsigned wide integer value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, \fBTcl_SetWideUIntObj\fR, and \fBTcl_SetBignumObj\fR, this points to the value in which to store an integral value. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR, this refers to the value from which to retrieve an integral value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when integral value |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 119 120 121 122 | provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types are provided by the C language standard. The \fBTcl_WideInt\fR type is a typedef defined to be whatever signed integral type covers at least the 64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending on the platform and the C compiler, the actual type might be \fBlong long int\fR, or something else. The \fBmp_int\fR type is a multiple-precision integer type defined by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, | > > > > > | | | | | | | | | | | 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 | provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types are provided by the C language standard. The \fBTcl_WideInt\fR type is a typedef defined to be whatever signed integral type covers at least the 64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending on the platform and the C compiler, the actual type might be \fBlong long int\fR, or something else. The \fBTcl_Size\fR typedef is a signed integer type capable of holding the maximum permitted lengths of Tcl values like strings and lists. Correspondingly, the preprocessor constant \fBTCL_SIZE_MAX\fR defines the maximum value that can be stored in a variable of this type. The \fBmp_int\fR type is a multiple-precision integer type defined by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, \fBTcl_NewWideUIntObj\fR, and \fBTcl_NewBignumObj\fR routines each create and return a new Tcl value initialized to the integral value of the argument. The returned Tcl value is unshared. .PP The \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, \fBTcl_SetWideUIntObj\fR, and \fBTcl_SetBignumObj\fR routines each set the value of an existing Tcl value pointed to by \fIobjPtr\fR to the integral value provided by the other argument. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value violates Tcl's copy-on-write policy. Any existing string representation or internal representation in the unshared Tcl value will be freed as a consequence of setting the new value. .PP The \fBTcl_GetIntForIndex\fR routine attempts to retrieve an index value from the Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the value is written to the storage provided by the caller. The attempt might fail if \fIobjPtr\fR does not hold an index value. If the attempt fails, then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL, |
| ︙ | ︙ | |||
181 182 183 184 185 186 187 | \fBTcl_NewObj\fR. .PP \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR do not modify the reference count of their \fIobjPtr\fR arguments, but do require that the object be unshared. .PP \fBTcl_GetIntFromObj\fR, \fBTcl_GetIntForIndex\fR, \fBTcl_GetLongFromObj\fR, | | > | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | \fBTcl_NewObj\fR. .PP \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR do not modify the reference count of their \fIobjPtr\fR arguments, but do require that the object be unshared. .PP \fBTcl_GetIntFromObj\fR, \fBTcl_GetIntForIndex\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetSizeIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR do not modify the reference count of their \fIobjPtr\fR arguments; they only read. Note however that this function may set the interpreter result; if that is the only place that is holding a reference to the object, it will be deleted. Also note that if \fBTcl_TakeBignumFromObj\fR is given an unshared value, the value of that object may be modified; it is intended to be used when the value is .QW consumed |
| ︙ | ︙ |
Changes to doc/ListObj.3.
| ︙ | ︙ | |||
195 196 197 198 199 200 201 | that is, \fIindex\fR is negative or greater than or equal to the number of elements in the list, \fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR and returns \fBTCL_OK\fR. Otherwise it returns \fBTCL_OK\fR after storing the element's value pointer. The reference count for the list element is not incremented; | | > > > > > > > > > > | 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 | that is, \fIindex\fR is negative or greater than or equal to the number of elements in the list, \fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR and returns \fBTCL_OK\fR. Otherwise it returns \fBTCL_OK\fR after storing the element's value pointer. The reference count for the list element is not incremented; the caller must do that if it needs to retain a pointer to the element, or "bounce" the reference count when the element is no longer needed. This is because a returned element may have a reference count of 0. Abstract Lists create a new element Obj on demand, and do not retain any element Obj values. Therefore, the caller is responsible for freeing the element when it is no longer needed. Note that this is a change from Tcl 8 where all list elements always have a reference count of at least 1. (See \fBABSTRACT LIST TYPES\fR, \fBSTORAGE MANAGEMENT OF VALUES\fR, Tcl_BounceRefCount(3), and lseq(n) for more information.) .PP \fBTcl_ListObjReplace\fR replaces zero or more elements of the list referenced by \fIlistPtr\fR with the \fIobjc\fR values in the array referenced by \fIobjv\fR. If \fIlistPtr\fR does not point to a list value, \fBTcl_ListObjReplace\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR |
| ︙ | ︙ |
Changes to doc/Method.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007 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 Tcl_Method 3 0.1 TclOO "TclOO Library Functions" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
'\"
'\" Copyright (c) 2007 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 Tcl_Method 3 0.1 TclOO "TclOO Library Functions"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodIsType2, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewInstanceMethod2, Tcl_NewMethod, Tcl_NewMethod2, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
.SH SYNOPSIS
.nf
\fB#include <tclOO.h>\fR
.sp
Tcl_Method
\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr,
clientData\fR)
.sp
Tcl_Method
\fBTcl_NewMethod2\fR(\fIinterp, class, nameObj, flags, methodType2Ptr,
clientData\fR)
.sp
Tcl_Method
\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr,
clientData\fR)
.sp
Tcl_Method
\fBTcl_NewInstanceMethod2\fR(\fIinterp, object, nameObj, flags, methodType2Ptr,
clientData\fR)
.sp
\fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR)
.sp
\fBTcl_ClassSetDestructor\fR(\fIinterp, class, method\fR)
.sp
Tcl_Class
\fBTcl_MethodDeclarerClass\fR(\fImethod\fR)
.sp
|
| ︙ | ︙ | |||
42 43 44 45 46 47 48 49 50 51 52 53 54 55 | .sp int \fBTcl_MethodIsPrivate\fR(\fImethod\fR) .sp int \fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR) .sp int \fBTcl_ObjectContextInvokeNext\fR(\fIinterp, context, objc, objv, skip\fR) .sp int \fBTcl_ObjectContextIsFiltering\fR(\fIcontext\fR) .sp Tcl_Method | > > > | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | .sp int \fBTcl_MethodIsPrivate\fR(\fImethod\fR) .sp int \fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR) .sp int \fBTcl_MethodIsType2\fR(\fImethod, methodType2Ptr, clientDataPtr\fR) .sp int \fBTcl_ObjectContextInvokeNext\fR(\fIinterp, context, objc, objv, skip\fR) .sp int \fBTcl_ObjectContextIsFiltering\fR(\fIcontext\fR) .sp Tcl_Method |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 87 88 89 90 91 92 93 | compatibility) for a non-exported method, .VS TIP500 and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. .VE TIP500 .AP Tcl_MethodType *methodTypePtr in A description of the type of the method to create, or the type of method to compare against. .AP void *clientData in A piece of data that is passed to the implementation of the method without interpretation. .AP void **clientDataPtr out A pointer to a variable in which to write the \fIclientData\fR value supplied when the method was created. If NULL, the \fIclientData\fR value will not be retrieved. | > > > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | compatibility) for a non-exported method, .VS TIP500 and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. .VE TIP500 .AP Tcl_MethodType *methodTypePtr in A description of the type of the method to create, or the type of method to compare against. .AP Tcl_MethodType2 *methodType2Ptr in A description of the type of the method to create, or the type of method to compare against. .AP void *clientData in A piece of data that is passed to the implementation of the method without interpretation. .AP void **clientDataPtr out A pointer to a variable in which to write the \fIclientData\fR value supplied when the method was created. If NULL, the \fIclientData\fR value will not be retrieved. |
| ︙ | ︙ | |||
122 123 124 125 126 127 128 129 130 131 | and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR. .VE TIP500 The type of the method can also be introspected upon to a limited degree; the function \fBTcl_MethodIsType\fR returns whether a method is of a particular type, assigning the per-method \fIclientData\fR to the variable pointed to by \fIclientDataPtr\fR if (that is non-NULL) if the type is matched. .SS "METHOD CREATION" .PP Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR, | > | > | | | | 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 | and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR. .VE TIP500 The type of the method can also be introspected upon to a limited degree; the function \fBTcl_MethodIsType\fR returns whether a method is of a particular type, assigning the per-method \fIclientData\fR to the variable pointed to by \fIclientDataPtr\fR if (that is non-NULL) if the type is matched. \fBTcl_MethodIsType2\fR does the same for TCL_OO_METHOD_VERSION_2. .SS "METHOD CREATION" .PP Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR, or by \fBTcl_NewMethod2\fR and \fBTcl_NewInstanceMethod2\fR which create a method attached to a class or an object respectively. In both cases, the \fInameObj\fR argument gives the name of the method to create, the \fIflags\fR argument states whether the method should be exported initially .VS TIP500 or be marked as a private method, .VE TIP500 the \fImethodTypePtr\fR or \fImethodType2Ptr\fR (for TCL_OO_METHOD_VERSION_2) argument describes the implementation of the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR argument gives some implementation-specific data that is passed on to the implementation of the method when it is called. .PP When the \fInameObj\fR argument to \fBTcl_NewMethod\fR or \fBTcl_NewMethod2\fR is NULL, an unnamed method is created, which is used for constructors and destructors. Constructors should be installed into their class using the \fBTcl_ClassSetConstructor\fR function, and destructors (which must not require any arguments) should be installed into their class using the \fBTcl_ClassSetDestructor\fR function. Unnamed methods should not be used for any other purpose, and named methods should not be used as either constructors or destructors. Also note that a NULL \fImethodTypePtr\fR or \fImethodType2Ptr\fR is used to provide internal signaling, and should not be used in client code. .SS "METHOD CALL CONTEXTS" .PP When a method is called, a method-call context reference is passed in as one of the arguments to the implementation function. This context can be inspected to provide information about the caller, but should not be retained beyond the moment when the method call terminates. |
| ︙ | ︙ | |||
174 175 176 177 178 179 180 | implementation has pushed one or more extra frames on the stack as part of its implementation, it is also responsible for temporarily popping those frames from the stack while the \fBTcl_ObjectContextInvokeNext\fR function is executing. Note also that the method-call context is \fInever\fR deleted during the execution of this function. .SH "METHOD TYPES" .PP | | | > > > > > > > > < | > | 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 |
implementation has pushed one or more extra frames on the stack as part of its
implementation, it is also responsible for temporarily popping those frames
from the stack while the \fBTcl_ObjectContextInvokeNext\fR function is
executing. Note also that the method-call context is \fInever\fR deleted
during the execution of this function.
.SH "METHOD TYPES"
.PP
The types of methods are described by a pointer to a Tcl_MethodType or
Tcl_MethodType2 (for TCL_OO_METHOD_VERSION_2) structure, which are defined as:
.PP
.CS
typedef struct {
int \fIversion\fR;
const char *\fIname\fR;
Tcl_MethodCallProc *\fIcallProc\fR;
Tcl_MethodDeleteProc *\fIdeleteProc\fR;
Tcl_CloneProc *\fIcloneProc\fR;
} \fBTcl_MethodType\fR;
typedef struct {
int \fIversion\fR;
const char *\fIname\fR;
Tcl_MethodCallProc2 *\fIcallProc\fR;
Tcl_MethodDeleteProc *\fIdeleteProc\fR;
Tcl_CloneProc *\fIcloneProc\fR;
} \fBTcl_MethodType2\fR;
.CE
.PP
The \fIversion\fR field should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT,
TCL_OO_METHOD_VERSION_1 or TCL_OO_METHOD_VERSION_2. The
\fIname\fR field provides a human-readable name for the type, and is the value
that is exposed via the \fBinfo class methodtype\fR and
\fBinfo object methodtype\fR Tcl commands.
.PP
The \fIcallProc\fR field gives a function that is called when the method is
invoked; it must never be NULL.
.PP
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
.CS
typedef int \fBTcl_MethodCallProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_ObjectContext \fIobjectContext\fR,
int \fIobjc\fR,
Tcl_Obj *const *\fIobjv\fR);
.CE
.PP
The \fIclientData\fR argument to a Tcl_MethodCallProc is the value that was
given when the method was created, the \fIinterp\fR is a place in which to
execute scripts and access variables as well as being where to put the result
of the method, and the \fIobjc\fR and \fIobjv\fR fields give the parameter
objects to the method. The calling context of the method can be discovered
| > > > > > > > | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
.CS
typedef int \fBTcl_MethodCallProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_ObjectContext \fIobjectContext\fR,
int \fIobjc\fR,
Tcl_Obj *const *\fIobjv\fR);
typedef int \fBTcl_MethodCallProc2\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_ObjectContext \fIobjectContext\fR,
Tcl_Size \fIobjc\fR,
Tcl_Obj *const *\fIobjv\fR);
.CE
.PP
The \fIclientData\fR argument to a Tcl_MethodCallProc is the value that was
given when the method was created, the \fIinterp\fR is a place in which to
execute scripts and access variables as well as being where to put the result
of the method, and the \fIobjc\fR and \fIobjv\fR fields give the parameter
objects to the method. The calling context of the method can be discovered
|
| ︙ | ︙ |
Changes to doc/Number.3.
1 2 3 4 5 6 | '\" '\" Contribution from Don Porter, NIST, 2022. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Contribution from Don Porter, NIST, 2022. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_GetNumber 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetNumber, Tcl_GetNumberFromObj \- get numeric value from Tcl value .SH SYNOPSIS .nf \fB#include <tcl.h>\fR |
| ︙ | ︙ |
Changes to doc/Object.3.
| ︙ | ︙ | |||
127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
void *\fIptr1\fR;
void *\fIptr2\fR;
} \fItwoPtrValue\fR;
struct {
void *\fIptr\fR;
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
a value's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
| > > > > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
void *\fIptr1\fR;
void *\fIptr2\fR;
} \fItwoPtrValue\fR;
struct {
void *\fIptr\fR;
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
struct {
void *\fIptr\fR;
Tcl_Size \fIsize\fR;
} \fIptrAndSize\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
a value's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 | If \fItypePtr\fR is NULL, the internal representation is invalid. .PP The \fIinternalRep\fR union member holds a value's internal representation. This is either a (long) integer, a double-precision floating-point number, a pointer to a value containing additional information | | | | > | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | If \fItypePtr\fR is NULL, the internal representation is invalid. .PP The \fIinternalRep\fR union member holds a value's internal representation. This is either a (long) integer, a double-precision floating-point number, a pointer to a value containing additional information needed by the value's type to represent the value, a \fBTcl_WideInt\fR integer, two arbitrary pointers, a pair made up of a pointer and an unsigned long integer, or a pair made up of a pointer and \fBTcl_Size\fR which is a signed integer type capable of holding the maximum lengths permitted in Tcl. .PP The \fIrefCount\fR member is used to tell when it is safe to free a value's storage. It holds the count of active references to the value. Maintaining the correct reference count is a key responsibility of extension writers. Reference counting is discussed below |
| ︙ | ︙ |
Changes to doc/ObjectType.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_ObjType 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_ObjType 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType, Tcl_FreeInternalRep, Tcl_InitStringRep, Tcl_HasStringRep, Tcl_StoreInternalRep, Tcl_FetchInternalRep \- manipulate Tcl value types .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_RegisterObjType\fR(\fItypePtr\fR) .sp const Tcl_ObjType * \fBTcl_GetObjType\fR(\fItypeName\fR) .sp int \fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR) .sp void \fBTcl_FreeInternalRep\fR(\fIobjPtr\fR) .sp char * \fBTcl_InitStringRep\fR(\fIobjPtr, bytes, numBytes\fR) .sp int \fBTcl_HasStringRep\fR(\fIobjPtr\fR) .sp void \fBTcl_StoreInternalRep\fR(\fIobjPtr, typePtr, irPtr\fR) .sp Tcl_ObjInternalRep * \fBTcl_FetchInternalRep\fR(\fIobjPtr, typePtr\fR) .fi .SH ARGUMENTS .AS "const char" *typeName .AP "const Tcl_ObjType" *typePtr in Points to the structure containing information about the Tcl value type. This storage must live forever, typically by being statically allocated. .AP "const char" *typeName in The name of a Tcl value type that \fBTcl_GetObjType\fR should look up. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP Tcl_Obj *objPtr in For \fBTcl_AppendAllObjTypes\fR, this points to the value onto which it appends the name of each value type as a list element. For \fBTcl_ConvertToType\fR, this points to a value that must have been the result of a previous call to \fBTcl_NewObj\fR. .AP "const char*" bytes in String representation. .AP "unsigned int" numBytes in Length of the string representation in bytes. .AP "const Tcl_ObjInternalRep*" irPtr in Internal object representation. .AP "const Tcl_ObjType*" typePtr in Requested internal representation type. .BE .SH DESCRIPTION .PP The procedures in this man page manage Tcl value types (sometimes referred to as object types or \fBTcl_ObjType\fRs for historical reasons). They are used to register new value types, look up types, |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 95 96 | as a test whether the conversion can be done (and in fact was done). .PP In many cases, the \fItypePtr->setFromAnyProc\fR routine will set \fIobjPtr->typePtr\fR to the argument value \fItypePtr\fR, but that is no longer guaranteed. The \fIsetFromAnyProc\fR is free to set the internal representation for \fIobjPtr\fR to make use of another related Tcl_ObjType, if it sees fit. .SH "THE TCL_OBJTYPE STRUCTURE" .PP | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
as a test whether the conversion can be done (and in fact was done).
.PP
In many cases, the \fItypePtr->setFromAnyProc\fR routine will
set \fIobjPtr->typePtr\fR to the argument value \fItypePtr\fR,
but that is no longer guaranteed. The \fIsetFromAnyProc\fR is
free to set the internal representation for \fIobjPtr\fR to make
use of another related Tcl_ObjType, if it sees fit.
.PP
\fBTcl_FreeInternalRep\fR performs the function of the existing internal
macro \fBTclInitStringRep\fR, but is extended to return a pointer to the
string rep, and to accept \fINULL\fR as a value for bytes.
When bytes is \fINULL\fR and \fIobjPtr\fR has no string rep, an uninitialzed
buffer of \fInumBytes\fR bytes is created for filling by the caller.
When \fIbytes\fR is \fINULL\fR and \fIobjPtr\fR has a string rep,
the string rep will be truncated to a length of \fInumBytes\fR bytes.
When \fInumBytes\fR is greater than zero, and the returned pointer is
\fINULL\fR, that indicates a failure to allocate memory for the string
representation.
The caller may then choose whether to raise an error or panic.
.PP
\fBTcl_HasStringRep\fR returns a boolean indicating whether or not a string
rep is currently stored in \fIobjPtr\fR.
This is used when the caller wants to act on \fIobjPtr\fR differently
depending on whether or not it is a pure value.
Typically this only makes sense in an extension if it is already known that
\fIobjPtr\fR possesses an internal type that is managed by the extension.
.PP
\fBTcl_StoreInternalRep\fR stores in \fIobjPtr\fR a copy of the internal
representation pointed to by \fIirPtr\fR and sets its type to \fItypePtr\fR.
When \fIirPtr\fR is \fINULL\fR, this leaves \fIobjPtr\fR without a
representation for type \fItypePtr\fR.
.PP
\fBTcl_FetchInternalRep\fR returns a pointer to the internal representation
stored in \fIobjPtr\fR that matches the requested type \fItypePtr\fR.
If no such internal representation is in \fIobjPtr\fR, return \fINULL\fR.
.PP
This returns a public type
.CS
typedef union Tcl_ObjInternalRep {...} Tcl_ObjInternalRep
.CE
where the contents are exactly the existing contents of the union in the
\fIinternalRep\fR field of the \fITcl_Obj\fR struct.
This definition permits us to pass internal representations and pointers to
them as arguments and results in public routines.
.SH "THE TCL_OBJTYPE STRUCTURE"
.PP
Extension writers can define new value types by defining four to twelve
procedures and initializing a Tcl_ObjType structure to describe the
type. Extension writers may also pass a pointer to their Tcl_ObjType
structure to \fBTcl_RegisterObjType\fR if they wish to permit other
extensions to look up their Tcl_ObjType by name with the
\fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is
defined as follows:
.PP
|
| ︙ | ︙ |
Changes to doc/OpenTcp.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-7 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-7 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_OpenTcpClient 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer, Tcl_OpenTcpServerEx \- procedures to open channels using TCP sockets .SH SYNOPSIS .nf |
| ︙ | ︙ |
Changes to doc/ParseArgs.3.
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | This argument takes zero or more following arguments; the handler callback function passed in \fIsrcPtr\fR returns how many (or a negative number to signal an error, in which case it should also set the interpreter result). The function will have the following signature: .RS .PP .CS | | | | | | | | | 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 |
This argument takes zero or more following arguments; the handler callback
function passed in \fIsrcPtr\fR returns how many (or a negative number to
signal an error, in which case it should also set the interpreter result). The
function will have the following signature:
.RS
.PP
.CS
typedef Tcl_Size (\fBTcl_ArgvGenFuncProc\fR)(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_Size \fIobjc\fR,
Tcl_Obj *const *\fIobjv\fR,
void *\fIdstPtr\fR);
.CE
.PP
The \fIclientData\fR is the value from the table entry, the \fIinterp\fR
is where to store any error messages, \fIobjc\fR and \fIobjv\fR describe
an array of all the remaining arguments, and \fIdstPtr\fR argument to the
\fBTcl_ArgvGenFuncProc\fR is the location to write the parsed value
(or values) to.
.RE
.IP \fBTCL_ARGV_HELP\fR
This special argument does not take any following value argument, but instead
causes \fBTcl_ParseArgsObjv\fR to generate an error message describing the
arguments supported. All other fields except the \fIhelpStr\fR field are
ignored.
.IP \fBTCL_ARGV_INT\fR
|
| ︙ | ︙ |
Changes to doc/Preserve.3.
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | .PP All the work of freeing the object is carried out by \fIfreeProc\fR. \fIFreeProc\fR must have arguments and result that match the type \fBTcl_FreeProc\fR: .PP .CS typedef void \fBTcl_FreeProc\fR( | | < < < | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
.PP
All the work of freeing the object is carried out by \fIfreeProc\fR.
\fIFreeProc\fR must have arguments and result that match the
type \fBTcl_FreeProc\fR:
.PP
.CS
typedef void \fBTcl_FreeProc\fR(
void *\fIblockPtr\fR);
.CE
.PP
The \fIblockPtr\fR argument to \fIfreeProc\fR will be the
same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR.
.PP
When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR
refers to storage allocated and returned by a prior call to
\fBTcl_Alloc\fR or another function of the Tcl library,
then the \fIfreeProc\fR argument should be given the special value of
\fBTCL_DYNAMIC\fR.
.PP
|
| ︙ | ︙ |
Changes to doc/SaveInterpState.3.
1 2 3 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) | < | < | | | > | | > | > > > > > > > > | > | < > > | | > | > | > | > | | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveInterpState 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- save and restore an interpreter's state .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_InterpState \fBTcl_SaveInterpState\fR(\fIinterp, status\fR) .sp int \fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) .sp \fBTcl_DiscardInterpState\fR(\fIstate\fR) .fi .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in Interpreter for which state should be saved. .AP int status in Return code value to save as part of interpreter state. .AP Tcl_InterpState state in Saved state token to be restored or discarded. .BE .SH DESCRIPTION .PP These routines allows a C procedure to take a snapshot of the current state of an interpreter so that it can be restored after a call to \fBTcl_Eval\fR or some other routine that modifies the interpreter state. .PP \fBTcl_SaveInterpState\fR stores a snapshot of the interpreter state in an opaque token returned by \fBTcl_SaveInterpState\fR. That token value may then be passed back to one of \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR, depending on whether the interp state is to be restored. So long as one of the latter two routines is called, Tcl will take care of memory management. .PP \fBTcl_SaveInterpState\fR takes a snapshot of those portions of interpreter state that make up the full result of script evaluation. This include the interpreter result, the return code (passed in as the \fIstatus\fR argument, and any return options, including \fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress. This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR. The call to \fBTcl_SaveInterpState\fR does not itself change the state of the interpreter. .PP \fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token previously returned by \fBTcl_SaveInterpState\fR and restores the state of the interp to the state held in that snapshot. The return value of \fBTcl_RestoreInterpState\fR is the status value originally passed to \fBTcl_SaveInterpState\fR when the snapshot token was created. .PP \fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR token previously returned by \fBTcl_SaveInterpState\fR when that snapshot is not to be restored to an interp. .PP The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR must eventually be passed to either \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once the \fBTcl_InterpState\fR token is passed to one of them, the token is no longer valid and should not be used anymore. .SH KEYWORDS result, state, interp |
Changes to doc/SetErrno.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SetErrno 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SetErrno 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg, Tcl_WinConvertError \- manipulate errno to store and retrieve error codes .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_SetErrno\fR(\fIerrorCode\fR) .sp int \fBTcl_GetErrno\fR() .sp const char * \fBTcl_ErrnoId\fR() .sp const char * \fBTcl_ErrnoMsg\fR(\fIerrorCode\fR) .sp void \fBTcl_WinConvertError\fR(\fIwinErrorCode\fR) .fi .SH ARGUMENTS .AS int errorCode .AP int errorCode in A POSIX error code such as \fBENOENT\fR. .AS unsigned int winErrorCode in .AP DWORD winErrorCode in A Windows or Winsock error code such as \fBERROR_FILE_NOT_FOUND\fR. .BE .SH DESCRIPTION .PP \fBTcl_SetErrno\fR and \fBTcl_GetErrno\fR provide portable access to the \fBerrno\fR variable, which is used to record a POSIX error code after system calls and other operations such as \fBTcl_Gets\fR. |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 63 64 65 | \fBTcl_ErrnoMsg\fR returns a human-readable string such as .QW "permission denied" that corresponds to the value of its \fIerrorCode\fR argument. The \fIerrorCode\fR argument is typically the value returned by \fBTcl_GetErrno\fR. The strings returned by these functions are statically allocated and the caller must not free or modify them. .SH KEYWORDS errno, error code, global variables | > > > | 63 64 65 66 67 68 69 70 71 72 73 74 75 | \fBTcl_ErrnoMsg\fR returns a human-readable string such as .QW "permission denied" that corresponds to the value of its \fIerrorCode\fR argument. The \fIerrorCode\fR argument is typically the value returned by \fBTcl_GetErrno\fR. The strings returned by these functions are statically allocated and the caller must not free or modify them. .PP \fBTcl_WinConvertError\fR (Windows only) maps the passed Windows or Winsock error code to a POSIX error and stores it in \fBerrno\fR. .SH KEYWORDS errno, error code, global variables |
Changes to doc/SetResult.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | > | | | | > | | | | > | > | > | > | > | < > | > > > > > > > > | | > > > | > | > > > | | > | | | | > > | > | > > | > > > > | > | | > | > > > > > | > > | | | > | | | | > > > | | < < > | | > | | > > | > | > > | | | > | | | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_SetResult 3 9.0 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult \- manipulate Tcl result
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetObjResult\fR(\fIinterp\fR)
.sp
\fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR)
.sp
const char *
\fBTcl_GetStringResult\fR(\fIinterp\fR)
.sp
\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *)NULL\fR)
.sp
\fBTcl_ResetResult\fR(\fIinterp\fR)
.sp
\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, element\fR)
.fi
.SH ARGUMENTS
.AS Tcl_FreeProc sourceInterp out
.AP Tcl_Interp *interp out
Interpreter whose result is to be modified or read.
.AP Tcl_Obj *objPtr in
Tcl value to become result for \fIinterp\fR.
.AP char *result in
String value to become result for \fIinterp\fR or to be
appended to the existing result.
.AP "const char" *element in
String value to append as a list element
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Address of procedure to call to release storage at
\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
\fBTCL_VOLATILE\fR.
.AP Tcl_Interp *sourceInterp in
Interpreter that the result and return options should be transferred from.
.AP Tcl_Interp *targetInterp in
Interpreter that the result and return options should be transferred to.
.AP int code in
Return code value that controls transfer of return options.
.BE
.SH DESCRIPTION
.PP
The procedures described here are utilities for manipulating the
result value in a Tcl interpreter.
The interpreter result may be either a Tcl value or a string.
For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR
set the interpreter result to, respectively, a value and a string.
Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR
return the interpreter result as a value and as a string.
The procedures always keep the string and value forms
of the interpreter result consistent.
For example, if \fBTcl_SetObjResult\fR is called to set
the result to a value,
then \fBTcl_GetStringResult\fR is called,
it will return the value's string representation.
.PP
\fBTcl_SetObjResult\fR
arranges for \fIobjPtr\fR to be the result for \fIinterp\fR,
replacing any existing result.
The result is left pointing to the value
referenced by \fIobjPtr\fR.
\fIobjPtr\fR's reference count is incremented
since there is now a new reference to it from \fIinterp\fR.
The reference count for any old result value
is decremented and the old result value is freed if no
references to it remain.
.PP
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value.
The value's reference count is not incremented;
if the caller needs to retain a long-term pointer to the value
they should use \fBTcl_IncrRefCount\fR to increment its reference count
in order to keep it from being freed too early or accidentally changed.
.PP
\fBTcl_SetResult\fR
arranges for \fIresult\fR to be the result for the current Tcl
command in \fIinterp\fR, replacing any existing result.
The \fIfreeProc\fR argument specifies how to manage the storage
for the \fIresult\fR argument;
it is discussed in the section
\fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below.
If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored
and \fBTcl_SetResult\fR
re-initializes \fIinterp\fR's result to point to an empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string.
If the result was set to a value by a \fBTcl_SetObjResult\fR call,
the value form will be converted to a string and returned.
If the value's string representation contains null bytes,
this conversion will lose information.
For this reason, programmers are encouraged to
write their code to use the new value API procedures
and to call \fBTcl_GetObjResult\fR instead.
.PP
\fBTcl_ResetResult\fR clears the result for \fIinterp\fR
and leaves the result in its normal empty initialized state.
If the result is a value,
its reference count is decremented and the result is left
pointing to an unshared value representing an empty string.
If the result is a dynamically allocated string, its memory is free*d
and the result is left as a empty string.
\fBTcl_ResetResult\fR also clears the error state managed by
\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR,
and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces.
It takes each of its \fIresult\fR arguments and appends them in order
to the current result associated with \fIinterp\fR.
If the result is in its initialized empty state (e.g. a command procedure
was just invoked or \fBTcl_ResetResult\fR was just called),
then \fBTcl_AppendResult\fR sets the result to the concatenation of
its \fIresult\fR arguments.
\fBTcl_AppendResult\fR may be called repeatedly as additional pieces
of the result are produced.
\fBTcl_AppendResult\fR takes care of all the
storage management issues associated with managing \fIinterp\fR's
result, such as allocating a larger result area if necessary.
It also manages conversion to and from the \fIresult\fR field of the
\fIinterp\fR so as to handle backward-compatibility with old-style
extensions.
Any number of \fIresult\fR arguments may be passed in a single
call; the last argument in the list must be (char *)NULL.
.PP
\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR
to \fItargetInterp\fR. The two interpreters must have been created in the
same thread. If \fIsourceInterp\fR and \fItargetInterp\fR are the same,
nothing is done. Otherwise, \fBTcl_TransferResult\fR moves the result
from \fIsourceInterp\fR to \fItargetInterp\fR, and resets the result
in \fIsourceInterp\fR. It also moves the return options dictionary as
controlled by the return code value \fIcode\fR in the same manner
as \fBTcl_GetReturnOptions\fR.
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
Use of the following procedures is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as a value
can be significantly more efficient.
.PP
\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in
that it allows results to be built up in pieces.
However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR
argument and it appends that argument to the current result
as a proper Tcl list element.
\fBTcl_AppendElement\fR adds backslashes or braces if necessary
to ensure that \fIinterp\fR's result can be parsed as a list and that
\fIelement\fR will be extracted as a single element.
Under normal conditions, \fBTcl_AppendElement\fR will add a space
character to \fIinterp\fR's result just before adding the new
list element, so that the list elements in the result are properly
separated.
However if the new list element is the first in a list or sub-list
(i.e. \fIinterp\fR's current result is empty, or consists of the
single character
.QW { ,
or ends in the characters
.QW " {" )
then no space is added.
.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how
the Tcl system is to manage the storage for the \fIresult\fR argument.
If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called
at a time when \fIinterp\fR holds a string result,
they do whatever is necessary to dispose of the old string result
(see the \fBTcl_Interp\fR manual entry for details on this).
.PP
If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIresult\fR
refers to an area of static storage that is guaranteed not to be
modified until at least the next call to \fBTcl_Eval\fR.
If \fIfreeProc\fR
is \fBTCL_DYNAMIC\fR it means that \fIresult\fR was allocated with a call
to \fBTcl_Alloc\fR and is now the property of the Tcl system.
\fBTcl_SetResult\fR will arrange for the string's storage to be
released by calling \fBTcl_Free\fR when it is no longer needed.
If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIresult\fR
points to an area of memory that is likely to be overwritten when
\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame).
In this case \fBTcl_SetResult\fR will make a copy of the string in
dynamically allocated storage and arrange for the copy to be the
result for the current Tcl command.
.PP
If \fIfreeProc\fR is not one of the values \fBTCL_STATIC\fR,
\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address
of a procedure that Tcl should call to free the string.
This allows applications to use non-standard storage allocators.
When Tcl no longer needs the storage for the string, it will
call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and
result that match the type \fBTcl_FreeProc\fR:
.PP
.CS
typedef void \fBTcl_FreeProc\fR(
void *\fIblockPtr\fR);
.CE
.PP
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIresult\fR passed to \fBTcl_SetResult\fR.
.SH "REFERENCE COUNT MANAGEMENT"
.PP
The interpreter result is one of the main places that owns references to
values, along with the bytecode execution stack, argument lists, variables,
and the list and dictionary collection values.
.PP
\fBTcl_SetObjResult\fR takes a value with an arbitrary reference count
\fI(specifically including zero)\fR and guarantees to increment the reference
count. If code wishes to continue using the value after setting it as the
result, it should add its own reference to it with \fBTcl_IncrRefCount\fR.
.PP
\fBTcl_GetObjResult\fR returns the current interpreter result value. This will
have a reference count of at least 1. If the caller wishes to keep the
interpreter result value, it should increment its reference count.
.PP
\fBTcl_GetStringResult\fR does not manipulate reference counts, but the string
it returns is owned by (and has a lifetime controlled by) the current
interpreter result value; it should be copied instead of being relied upon to
persist after the next Tcl API call, as most Tcl operations can modify the
interpreter result.
.PP
\fBTcl_SetResult\fR, \fBTcl_AppendResult\fR,
\fBTcl_AppendElement\fR, and \fBTcl_ResetResult\fR all modify the interpreter
result. They may cause the old interpreter result to have its reference count
decremented and a new interpreter result to be allocated. After they have been
called, the reference count of the interpreter result is guaranteed to be 1.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions
.SH KEYWORDS
append, command, element, list, value, result, return value, interpreter
|
Changes to doc/StringObj.3.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp Tcl_Obj * \fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR) .sp \fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR) .sp \fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR) .sp char * \fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp char * \fBTcl_GetString\fR(\fIobjPtr\fR) | > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp Tcl_Obj * \fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR) .sp void \fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR) .sp void \fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR) .sp char * \fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp char * \fBTcl_GetString\fR(\fIobjPtr\fR) |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 | .sp Tcl_Size \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp Tcl_Obj * \fBTcl_GetRange\fR(\fIobjPtr, first, last\fR) .sp \fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR) .sp \fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR) .sp \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp | > > > > | > > > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | .sp Tcl_Size \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp Tcl_Obj * \fBTcl_GetRange\fR(\fIobjPtr, first, last\fR) .sp void \fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR) .sp void \fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR) .sp void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *)NULL\fR) .sp void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) .sp int \fBTcl_AppendFormatToObj\fR(\fIinterp, objPtr, format, objc, objv\fR) .sp Tcl_Obj * \fBTcl_ObjPrintf\fR(\fIformat, ...\fR) .sp void \fBTcl_AppendPrintfToObj\fR(\fIobjPtr, format, ...\fR) .sp void \fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR) .sp int \fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR) .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) |
| ︙ | ︙ | |||
201 202 203 204 205 206 207 | 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 | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | 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 is negative, then the returned string ends at the end of the value. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed to bytes) in the string value. .PP \fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and \fIlength\fR to the string representation of the value specified by |
| ︙ | ︙ | |||
238 239 240 241 242 243 244 | \fIobjPtr\fR. .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | \fIobjPtr\fR. .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument must be (char *)NULL to indicate the end of the list. .PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. This can be handy when the string to be appended might be very large, but the value being constructed should not be allowed to grow without bound. A common usage is when constructing an error message, where the end result should be kept short enough to be read. |
| ︙ | ︙ | |||
338 339 340 341 342 343 344 345 346 347 348 349 350 351 | Tcl_Obj *newPtr = \fBTcl_ObjPrintf\fR(format, ...); \fBTcl_AppendObjToObj\fR(objPtr, newPtr); \fBTcl_DecrRefCount\fR(newPtr); .CE .PP but with greater convenience and efficiency when the appending functionality is needed. .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR argument is greater than the space allocated for the value's string, then the string space is reallocated and the old value is copied to the new space; the bytes between the old length of the string and the new length may have arbitrary values. | > > > > > > > > > > > > > > > > | 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 |
Tcl_Obj *newPtr = \fBTcl_ObjPrintf\fR(format, ...);
\fBTcl_AppendObjToObj\fR(objPtr, newPtr);
\fBTcl_DecrRefCount\fR(newPtr);
.CE
.PP
but with greater convenience and efficiency when the appending
functionality is needed.
.PP
When printing integer types defined by Tcl, such as \fBTcl_Size\fR
or \fBTcl_WideInt\fR, a format size specifier is needed as the
integer width of those types is dependent on the Tcl version,
platform and compiler. To accomodate these differences, Tcl defines
C preprocessor symbols \fBTCL_LL_MODIFER\fR and
\fBTCL_SIZE_MODIFER\fR for use when formatting values of type
\fBTcl_WideInt\fR and \fBTcl_Size\fR respectively. Their usage
is illustrated by
.PP
.CS
Tcl_WideInt wide;
Tcl_Size len;
Tcl_Obj *wideObj = Tcl_ObjPrintf("wide = %" \fBTCL_LL_MODIFIER\fR "d", wide);
Tcl_Obj *lenObj = Tcl_ObjPrintf("len = %" \fBTCL_SIZE_MODIFIER\fR "d", len);
.CE
.PP
The \fBTcl_SetObjLength\fR procedure changes the length of the
string value of its \fIobjPtr\fR argument. If the \fInewLength\fR
argument is greater than the space allocated for the value's
string, then the string space is reallocated and the old value
is copied to the new space; the bytes between the old length of
the string and the new length may have arbitrary values.
|
| ︙ | ︙ |
Changes to doc/Tcl.n.
1 2 3 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. | < < | | | > > > | | > | < < | | > | < < < < < < < < | > > | | < < < | < < > | < < < < < < | | > > > | > | < > | < < < < | | | < | > | | | | | < < | < > > | | < | > | | | > > > > > > | < > | | | > > > > | | > > > > | | | | < < > | > | > > > > > > > > > > > | > > | > > | > | > > > | | > > > > > < < | | > > | | | > > | | < | < | < | < | < | < | < | | | | > | | < > | | > > | | > > | | > > | | > | | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | 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 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl n "8.6" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.SH NAME
Tcl \- Tool Command Language
.SH SYNOPSIS
Summary of Tcl language syntax.
.BE
.SH DESCRIPTION
.PP
The following rules define the syntax and semantics of the Tcl language:
.IP "[1] \fBCommands.\fR"
A Tcl script is a string containing one or more commands.
Semi-colons and newlines are command separators unless quoted as
described below.
Close brackets are command terminators during command substitution
(see below) unless quoted.
.IP "[2] \fBEvaluation.\fR"
A command is evaluated in two steps.
First, the Tcl interpreter breaks the command into \fIwords\fR
and performs substitutions as described below.
These substitutions are performed in the same way for all
commands.
Secondly, the first word is used to locate a routine to
carry out the command, and the remaining words of the command are
passed to that routine.
The routine is free to interpret each of its words
in any way it likes, such as an integer, variable name, list,
or Tcl script.
Different commands interpret their words differently.
.IP "[3] \fBWords.\fR"
Words of a command are separated by white space (except for
newlines, which are command separators).
.IP "[4] \fBDouble quotes.\fR"
If the first character of a word is double-quote
.PQ \N'34'
then the word is terminated by the next double-quote character.
If semi-colons, close brackets, or white space characters
(including newlines) appear between the quotes then they are treated
as ordinary characters and included in the word.
Command substitution, variable substitution, and backslash substitution
are performed on the characters between the quotes as described below.
The double-quotes are not retained as part of the word.
.IP "[5] \fBArgument expansion.\fR"
If a word starts with the string
.QW {*}
followed by a non-whitespace character, then the leading
.QW {*}
is removed and the rest of the word is parsed and substituted as any other
word. After substitution, the word is parsed as a list (without command or
variable substitutions; backslash substitutions are performed as is normal for
a list and individual internal words may be surrounded by either braces or
double-quote characters), and its words are added to the command being
substituted. For instance,
.QW "cmd a {*}{b [c]} d {*}{$e f {g h}}"
is equivalent to
.QW "cmd a b {[c]} d {$e} f {g h}" .
.IP "[6] \fBBraces.\fR"
If the first character of a word is an open brace
.PQ {
and rule [5] does not apply, then
the word is terminated by the matching close brace
.PQ } "" .
Braces nest within the word: for each additional open
brace there must be an additional close brace (however,
if an open brace or close brace within the word is
quoted with a backslash then it is not counted in locating the
matching close brace).
No substitutions are performed on the characters between the
braces except for backslash-newline substitutions described
below, nor do semi-colons, newlines, close brackets,
or white space receive any special interpretation.
The word will consist of exactly the characters between the
outer braces, not including the braces themselves.
.IP "[7] \fBCommand substitution.\fR"
If a word contains an open bracket
.PQ [
then Tcl performs \fIcommand substitution\fR.
To do this it invokes the Tcl interpreter recursively to process
the characters following the open bracket as a Tcl script.
The script may contain any number of commands and must be terminated
by a close bracket
.PQ ] "" .
The result of the script (i.e. the result of its last command) is
substituted into the word in place of the brackets and all of the
characters between them.
There may be any number of command substitutions in a single word.
Command substitution is not performed on words enclosed in braces.
.IP "[8] \fBVariable substitution.\fR"
If a word contains a dollar-sign
.PQ $
followed by one of the forms
described below, then Tcl performs \fIvariable
substitution\fR: the dollar-sign and the following characters are
replaced in the word by the value of a variable.
Variable substitution may take any of the following forms:
.RS
.TP 15
\fB$\fIname\fR
.
\fIName\fR is the name of a scalar variable; the name is a sequence
of one or more characters that are a letter, digit, underscore,
or namespace separators (two or more colons).
Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR,
\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR).
.TP 15
\fB$\fIname\fB(\fIindex\fB)\fR
.
\fIName\fR gives the name of an array variable and \fIindex\fR gives
the name of an element within that array.
\fIName\fR must contain only letters, digits, underscores, and
namespace separators, and may be an empty string.
Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR,
\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR).
Command substitutions, variable substitutions, and backslash
substitutions are performed on the characters of \fIindex\fR.
.TP 15
\fB${\fIname\fB}\fR
.
\fIName\fR is the name of a scalar variable or array element. It may contain
any characters whatsoever except for close braces. It indicates an array
element if \fIname\fR is in the form
.QW \fIarrayName\fB(\fIindex\fB)\fR
where \fIarrayName\fR does not contain any open parenthesis characters,
.QW \fB(\fR ,
or close brace characters,
.QW \fB}\fR ,
and \fIindex\fR can be any sequence of characters except for close brace
characters. No further
substitutions are performed during the parsing of \fIname\fR.
.PP
There may be any number of variable substitutions in a single word.
Variable substitution is not performed on words enclosed in braces.
.PP
Note that variables may contain character sequences other than those listed
above, but in that case other mechanisms must be used to access them (e.g.,
via the \fBset\fR command's single-argument form).
.RE
.IP "[9] \fBBackslash substitution.\fR"
If a backslash
.PQ \e
appears within a word then \fIbackslash substitution\fR occurs.
In all cases but those described below the backslash is dropped and
the following character is treated as an ordinary
character and included in the word.
This allows characters such as double quotes, close brackets,
and dollar signs to be included in words without triggering
special processing.
The following table lists the backslash sequences that are
handled specially, along with the value that replaces each sequence.
.RS
.RS
.RS
.TP 7
\e\fBa\fR
Audible alert (bell) (Unicode U+000007).
.TP 7
\e\fBb\fR
Backspace (Unicode U+000008).
.TP 7
\e\fBf\fR
Form feed (Unicode U+00000C).
.TP 7
\e\fBn\fR
Newline (Unicode U+00000A).
.TP 7
\e\fBr\fR
Carriage-return (Unicode U+00000D).
.TP 7
\e\fBt\fR
Tab (Unicode U+000009).
.TP 7
\e\fBv\fR
Vertical tab (Unicode U+00000B).
.TP 7
\e\fB<newline>\fIwhiteSpace\fR
.
A single space character replaces the backslash, newline, and all spaces
and tabs after the newline. This backslash sequence is unique in that it
is replaced in a separate pre-pass before the command is actually parsed.
This means that it will be replaced even when it occurs between braces,
and the resulting space will be treated as a word separator if it is not
in braces or quotes.
.TP 7
\e\e
Backslash
.PQ \e "" .
.TP 7
\e\fIooo\fR
.
The digits \fIooo\fR (one, two, or three of them) give a eight-bit octal
value for the Unicode character that will be inserted, in the range
\fI000\fR\(en\fI377\fR (i.e., the range U+000000\(enU+0000FF).
The parser will stop just before this range overflows, or when
the maximum of three digits is reached. The upper bits of the Unicode
character will be 0.
.TP 7
\e\fBx\fIhh\fR
.
The hexadecimal digits \fIhh\fR (one or two of them) give an eight-bit
hexadecimal value for the Unicode character that will be inserted. The upper
bits of the Unicode character will be 0 (i.e., the character will be in the
range U+000000\(enU+0000FF).
.TP 7
\e\fBu\fIhhhh\fR
.
The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a
sixteen-bit hexadecimal value for the Unicode character that will be
inserted. The upper bits of the Unicode character will be 0 (i.e., the
character will be in the range U+000000\(enU+00FFFF).
.TP 7
\e\fBU\fIhhhhhhhh\fR
.
The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a
twenty-one-bit hexadecimal value for the Unicode character that will be
inserted, in the range U+000000\(enU+10FFFF. The parser will stop just
before this range overflows, or when the maximum of eight digits
is reached. The upper bits of the Unicode character will be 0.
.RE
.RE
.PP
Backslash substitution is not performed on words enclosed in braces,
except for backslash-newline as described above.
.RE
.IP "[10] \fBComments.\fR"
If a hash character
.PQ #
appears at a point where Tcl is
expecting the first character of the first word of a command,
then the hash character and the characters that follow it, up
through the next newline, are treated as a comment and ignored.
The comment character only has significance when it appears
at the beginning of a command.
.IP "[11] \fBOrder of substitution.\fR"
Each character is processed exactly once by the Tcl interpreter
as part of creating the words of a command.
For example, if variable substitution occurs then no further
substitutions are performed on the value of the variable; the
value is inserted into the word verbatim.
If command substitution occurs then the nested command is
processed entirely by the recursive call to the Tcl interpreter;
no substitutions are performed before making the recursive
call and no additional substitutions are performed on the result
of the nested script.
.RS
.PP
Substitutions take place from left to right, and each substitution is
evaluated completely before attempting to evaluate the next. Thus, a
sequence like
.PP
.CS
set y [set x 0][incr x][incr x]
.CE
.PP
will always set the variable \fIy\fR to the value, \fI012\fR.
.RE
.IP "[12] \fBSubstitution and word boundaries.\fR"
Substitutions do not affect the word boundaries of a command,
except for argument expansion as specified in rule [5].
For example, during variable substitution the entire value of
the variable becomes part of a single word, even if the variable's
value contains spaces.
.SH KEYWORDS
backslash, command, comment, script, substitution, variable
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/TclZlib.3.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | .nf #include <tcl.h> .sp int \fBTcl_ZlibDeflate\fR(\fIinterp, format, dataObj, level, dictObj\fR) .sp int | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | .nf #include <tcl.h> .sp int \fBTcl_ZlibDeflate\fR(\fIinterp, format, dataObj, level, dictObj\fR) .sp int \fBTcl_ZlibInflate\fR(\fIinterp, format, dataObj, bufferSize, dictObj\fR) .sp unsigned int \fBTcl_ZlibCRC32\fR(\fIinitValue, bytes, length\fR) .sp unsigned int \fBTcl_ZlibAdler32\fR(\fIinitValue, bytes, length\fR) .sp |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 88 89 90 91 92 93 94 | \fIformat\fR is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. If a NULL is passed, a default header will be used on compression and the header will be ignored (apart from integrity checks) on decompression. See the section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this dictionary. .AP "unsigned int" initValue in The initial value for the checksum algorithm. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. .AP Tcl_Size length in The number of bytes in the array. .AP int mode in What mode to operate the stream in. Should be either | > > > | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | \fIformat\fR is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. If a NULL is passed, a default header will be used on compression and the header will be ignored (apart from integrity checks) on decompression. See the section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this dictionary. .AP "unsigned int" initValue in The initial value for the checksum algorithm. .AP "Tcl_Size" bufferSize in A hint as to what size of buffer is to be used to receive the data. Use 0 to use a geric guess based on the input data. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. .AP Tcl_Size length in The number of bytes in the array. .AP int mode in What mode to operate the stream in. Should be either |
| ︙ | ︙ |
Changes to doc/Thread.3.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | .AP int *result out The referred storage is used to place the exit code of the thread waited upon into it. .BE .SH INTRODUCTION Beginning with the 8.1 release, the Tcl core is thread safe, which allows you to incorporate Tcl into multithreaded applications without | | < < < | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | .AP int *result out The referred storage is used to place the exit code of the thread waited upon into it. .BE .SH INTRODUCTION Beginning with the 8.1 release, the Tcl core is thread safe, which allows you to incorporate Tcl into multithreaded applications without customizing the Tcl core. .PP An important constraint of the Tcl threads implementation is that \fIonly the thread that created a Tcl interpreter can use that interpreter\fR. In other words, multiple threads can not access the same Tcl interpreter. (However, a single thread can safely create and use multiple interpreters.) .SH DESCRIPTION |
| ︙ | ︙ |
Changes to doc/apply.n.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | }}} set vbl 123 set vbl abc .CE .SH "SEE ALSO" proc(n), uplevel(n) .SH KEYWORDS | | | 92 93 94 95 96 97 98 99 100 101 102 | }}} set vbl 123 set vbl abc .CE .SH "SEE ALSO" proc(n), uplevel(n) .SH KEYWORDS anonymous function, argument, lambda, procedure '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/array.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH array n 9.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables .SH SYNOPSIS \fBarray \fIoption arrayName\fR ?\fIarg arg ...\fR? |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | .TP \fBarray exists \fIarrayName\fR . Returns 1 if \fIarrayName\fR is an array variable, 0 if there is no variable by that name or if it is a scalar variable. .\" METHOD: for .TP | | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
.TP
\fBarray exists \fIarrayName\fR
.
Returns 1 if \fIarrayName\fR is an array variable, 0 if there
is no variable by that name or if it is a scalar variable.
.\" METHOD: for
.TP
\fBarray for {\fIkeyVariable valueVariable\fB} \fIarrayName body\fR
.
The first argument is a two element list of variable names for the
key and value of each entry in the array. The second argument is the
array name to iterate over. The third argument is the body to execute
for each key and value returned.
The ordering of the returned keys is undefined.
If an array element is deleted or a new array element is inserted during
the \fIarray for\fR process, the command will terminate with an error.
.\" METHOD: get
.TP
\fBarray get \fIarrayName\fR ?\fIpattern\fR?
.
Returns a list containing pairs of elements. The first
element in each pair is the name of an element in \fIarrayName\fR
and the second element of each pair is the value of the
|
| ︙ | ︙ |
Changes to doc/catch.n.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | value corresponding to the exceptional return code returned by evaluation of \fIscript\fR. Tcl defines the normal return code from script evaluation to be zero (0), or \fBTCL_OK\fR. Tcl also defines four exceptional return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR), and 4 (\fBTCL_CONTINUE\fR). Errors during evaluation of a script are indicated by a return code of \fBTCL_ERROR\fR. The other exceptional return codes are returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands | | | | > > | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | value corresponding to the exceptional return code returned by evaluation of \fIscript\fR. Tcl defines the normal return code from script evaluation to be zero (0), or \fBTCL_OK\fR. Tcl also defines four exceptional return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR), and 4 (\fBTCL_CONTINUE\fR). Errors during evaluation of a script are indicated by a return code of \fBTCL_ERROR\fR. The other exceptional return codes are returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands and in other special situations as documented. New commands defined by Tcl packages as well as scripts that make use of the \fBreturn \-code\fR command can return other integer values as the return code. These must however lie outside the range reserved for Tcl as documented for the \fBreturn\fR command. .PP If the \fIresultVarName\fR argument is given, then the variable it names is set to the result of the script evaluation. When the return code from the script is 1 (\fBTCL_ERROR\fR), the value stored in \fIresultVarName\fR is an error message. When the return code from the script is 0 (\fBTCL_OK\fR), the value stored in \fIresultVarName\fR is the value returned from \fIscript\fR. .PP |
| ︙ | ︙ |
Changes to doc/chan.n.
1 2 | '\" '\" Copyright (c) 2005-2006 Donal K. Fellows | < | | | | > | | > | < | | | | | > > | | | < | < < | > | > | > | | | > | | | > < > > | | > < | < | < < | > | > > > > > > > | < > < < < > > > > < < > > > > | | > | | | | | | | | > > | > | | > | | > > | | > | | | | | | > | | > | > > | | | > > | | | < | > > > > | > > > | > > > | > > | | | > > | | < < < | > | < | > | | | | | | | > | | | | | | > | > | > | < > | > > | | | > > | | | > | | | | | | > > | | > | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 |
'\"
'\" Copyright (c) 2005-2006 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.TH chan n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
chan \- Read, write and manipulate channels
.SH SYNOPSIS
\fBchan \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command provides several operations for reading from, writing to
and otherwise manipulating open channels (such as have been created
with the \fBopen\fR and \fBsocket\fR commands, or the default named
channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to
the process's standard input, output and error streams respectively).
\fIOption\fR indicates what to do with the channel; any unique
abbreviation for \fIoption\fR is acceptable. Valid options are:
.\" METHOD: blocked
.TP
\fBchan blocked \fIchannel\fR
.
This tests whether the last input operation on the channel called
\fIchannel\fR failed because it would have otherwise caused the
process to block, and returns 1 if that was the case. It returns 0
otherwise. Note that this only ever returns 1 when the channel has
been configured to be non-blocking; all Tcl channels have blocking
turned on by default.
.\" METHOD: close
.TP
\fBchan close \fIchannel\fR ?\fIdirection\fR?
.
Close and destroy the channel called \fIchannel\fR. Note that this
deletes all existing file-events registered on the channel.
If the \fIdirection\fR argument (which must be \fBread\fR or \fBwrite\fR or
any unique abbreviation of them) is present, the channel will only be
half-closed, so that it can go from being read-write to write-only or
read-only respectively. If a read-only channel is closed for reading, it is
the same as if the channel is fully closed, and respectively similar for
write-only channels. Without the \fIdirection\fR argument, the channel is
closed for both reading and writing (but only if those directions are
currently open). It is an error to close a read-only channel for writing, or a
write-only channel for reading.
.RS
.PP
As part of closing the channel, all buffered output is flushed to the
channel's output device (only if the channel is ceasing to be writable), any
buffered input is discarded (only if the channel is ceasing to be readable),
the underlying operating system resource is closed and \fIchannel\fR becomes
unavailable for future use (both only if the channel is being completely
closed).
.PP
If the channel is blocking and the channel is ceasing to be writable, the
command does not return until all output is flushed. If the channel is
non-blocking and there is unflushed output, the channel remains open and the
command returns immediately; output will be flushed in the background and the
channel will be closed when all the flushing is complete.
.PP
If \fIchannel\fR is a blocking channel for a command pipeline then
\fBchan close\fR waits for the child processes to complete.
.PP
If the channel is shared between interpreters, then \fBchan close\fR
makes \fIchannel\fR unavailable in the invoking interpreter but has
no other effect until all of the sharing interpreters have closed the
channel. When the last interpreter in which the channel is registered
invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions
described above occur. With half-closing, the half-close of the channel only
applies to the current interpreter's view of the channel until all channels
have closed it in that direction (or completely).
See the \fBinterp\fR command for a description of channel sharing.
.PP
Channels are automatically fully closed when an interpreter is destroyed and
when the process exits. Channels are switched to blocking mode, to
ensure that all output is correctly flushed before the process exits.
.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output. If a command in a command
pipeline created with \fBopen\fR returns an error, \fBchan close\fR
generates an error (similar to the \fBexec\fR command.)
.PP
Note that half-closes of sockets and command pipelines can have important side
effects because they result in a shutdown() or close() of the underlying
system resource, which can change how other processes or systems respond to
the Tcl program.
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.
From 8.6 on (TIP#398), nonblocking channels are no longer switched to
blocking mode when exiting; this guarantees a timely exit even when the
peer or a communication channel is stalled. To ensure proper flushing of
stalled nonblocking channels on exit, one must now either (a) actively
switch them back to blocking or (b) use the environment variable
\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
.QW \fB0\fR
restores the previous behavior.
.RE
.\" METHOD: configure
.TP
\fBchan configure \fIchannel\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
.
Query or set the configuration options of the channel named
\fIchannel\fR.
.RS
.PP
If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the
command returns a list containing alternating option names and values
for the channel. If \fIoptionName\fR is supplied but no \fIvalue\fR
then the command returns the current value of the given option. If
one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied,
the command sets each of the named options to the corresponding
\fIvalue\fR; in this case the return value is an empty string.
.PP
The options described below are supported for all channels. In
addition, each channel type may add options that only it supports. See
the manual entry for the command that creates each type of channel
for the options supported by that specific type of channel. For
example, see the manual entry for the \fBsocket\fR command for additional
options for sockets, and the \fBopen\fR command for additional options for
serial devices.
.RE
.\" OPTION: -blocking
.TP
\fB\-blocking\fI boolean\fR
.
The \fB\-blocking\fR option determines whether I/O operations on the
channel can cause the process to block indefinitely. The value of the
option must be a proper boolean value. Channels are normally in
blocking mode; if a channel is placed into non-blocking mode it will
affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan
puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the
documentation for those commands for details. For non-blocking mode to
work correctly, the application must be using the Tcl event loop
(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR
command).
.\" OPTION: -buffering
.TP
\fB\-buffering\fI newValue\fR
.
If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output
until its internal buffer is full or until the \fBchan flush\fR
command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O
system will automatically flush output for the channel whenever a
newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O
system will flush automatically after every output operation. The
default is for \fB\-buffering\fR to be set to \fBfull\fR except for
channels that connect to terminal-like devices; for these channels the
initial setting is \fBline\fR. Additionally, \fBstdin\fR and
\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set
to \fBnone\fR.
.\" OPTION: -buffersize
.TP
\fB\-buffersize\fI newSize\fR
.
\fInewSize\fR must be an integer; its value is used to set the size
of buffers, in bytes, subsequently allocated for this channel to store
input or output. \fInewSize\fR must be a number of no more than one
million, allowing buffers of up to one million bytes in size.
.\" OPTION: -encoding
.TP
\fB\-encoding\fR \fIname\fR
.
This option is used to specify the encoding of the channel as one of
the named encodings returned by \fBencoding names\fR, so that the
data can be converted to and from
Unicode for use in Tcl. For instance, in order for Tcl to read
characters from a Japanese file in \fBshiftjis\fR and properly process
and display the contents, the encoding would be set to \fBshiftjis\fR.
Thereafter, when reading from the channel, the bytes in the Japanese
file would be converted to Unicode as they are read. Writing is also
supported \- as Tcl strings are written to the channel they will
automatically be converted to the specified encoding on output.
.RS
.PP
If a file contains pure binary data (for instance, a JPEG image), the
encoding for the channel should be configured to be \fBiso8859-1\fR. Tcl
will then assign no interpretation to the data in the file and simply
read or write raw bytes. The Tcl \fBbinary\fR command can be used to
manipulate this byte-oriented data. It is usually better to set the
\fB\-translation\fR option to \fBbinary\fR when you want to transfer
binary data, as this turns off the other automatic interpretations of
the bytes in the stream as well.
.PP
The default encoding for newly opened channels is the same platform-
and locale-dependent system encoding used for interfacing with the
operating system, as returned by \fBencoding system\fR.
.RE
.\" OPTION: -eofchar
.TP
\fB\-eofchar\fI char\fR
.
This option supports DOS file systems that use Control-z (\ex1A) as an
end of file marker. If \fIchar\fR is not an empty string, then this
character signals end-of-file when it is encountered during input.
Otherwise (the default) there is no special end of file character marker.
The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f;
attempting to set \fB\-eofchar\fR to a value outside of this range will
generate an error.
.VS "TCL8.7 TIP656"
.\" OPTION: -profile
.TP
\fB\-profile\fI profile\fR
.
Specifies the encoding profile to be used on the channel. The encoding
transforms in use for the channel's input and output will then be subject to the
rules of that profile. Any failures will result in a channel error. See
\fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding
profiles.
.VE "TCL8.7 TIP656"
.\" OPTION: -translation
.TP
\fB\-translation\fI translation\fR
.TP
\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR
.
In Tcl scripts the end of a line is always represented using a single
newline character (\en). However, in actual files and devices the end
of a line may be represented differently on different platforms, or
even for different devices on the same platform. For example, under
UNIX newlines are used in files, whereas carriage-return-linefeed
sequences are normally used in network connections. On input (i.e.,
with \fBchan gets\fR and \fBchan read\fR) the Tcl I/O system
automatically translates the external end-of-line representation into
newline characters. Upon output (i.e., with \fBchan puts\fR), the I/O
system translates newlines to the external end-of-line representation.
The default translation mode, \fBauto\fR, handles all the common cases
automatically, but the \fB\-translation\fR option provides explicit
control over the end of line translations.
.RS
.PP
The value associated with \fB\-translation\fR is a single item for
read-only and write-only channels. The value is a two-element list for
read-write channels; the read translation mode is the first element of
the list, and the write translation mode is the second element. As a
convenience, when setting the translation mode for a read-write channel
you can specify a single value that will apply to both reading and
writing. When querying the translation mode of a read-write channel, a
two-element list will always be returned. The following values are
currently supported:
.IP \fBauto\fR
As the input translation mode, \fBauto\fR treats any of newline
(\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by
a newline (\fBcrlf\fR) as the end of line representation. The end of
line representation can even change from line-to-line, and all cases
are translated to a newline. As the output translation mode,
\fBauto\fR chooses a platform specific representation; for sockets on
all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses
\fBlf\fR, and for the various flavors of Windows it chooses
\fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR
for both input and output.
.IP \fBbinary\fR
Like \fBlf\fR, no end-of-line translation is performed, but in addition, sets
\fB\-eofchar\fR to the empty string to disable it, and sets \fB\-encoding\fR
to \fBiso8859-1\fR. With this one setting, a channel is fully configured
for binary input and output: Each byte read from the channel
becomes the Unicode character having the same value as that byte, and each
character written to the channel becomes a single byte in the output. This
makes it possible to work seamlessly with binary data as long as each character
in the data remains in the range of 0 to 255 so that there is no distinction
between binary data and text. For example, A JPEG image can be read from a
such a channel, manipulated, and then written back to such a channel.
.IP \fBcr\fR
The end of a line in the underlying file or device is represented by a
single carriage return character. As the input translation mode,
\fBcr\fR mode converts carriage returns to newline characters. As the
output translation mode, \fBcr\fR mode translates newline characters
to carriage returns.
.IP \fBcrlf\fR
The end of a line in the underlying file or device is represented by a
carriage return character followed by a linefeed character. As the
input translation mode, \fBcrlf\fR mode converts
carriage-return-linefeed sequences to newline characters. As the
output translation mode, \fBcrlf\fR mode translates newline characters
to carriage-return-linefeed sequences. This mode is typically used on
Windows platforms and for network connections.
.IP \fBlf\fR
The end of a line in the underlying file or device is represented by a
single newline (linefeed) character. In this mode no translations
occur during either input or output. This mode is typically used on
UNIX platforms.
.RE
.\" METHOD: copy
.TP
\fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.
Reads characters from \fIinputChan\fR and writes them to \fIoutputChan\fR until
all characters are copied, blocking until the copy is complete and returning
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | .QW "channel busy" error. .RE .\" METHOD: create .TP \fBchan create \fImode cmdPrefix\fR . | | | > > | > > > > > | > | | > | > | < > > > | > > | | > > | < > > | > > | | | > | | | > | > > > > | | > > | | > | | | | | > | < < | | | > | | | < < < | | < > > > > | | < > | | | < | > | | | > > > | > | < < > > > < | | > | | | > | > | | < | > > > > > | > > > | > > > > > | | | > > > | | < | | < | | | > > | | > > > > > > > > > > > > | | | | > > > | > > > > > > > > > > > > > > > > > | > | | > | < < | < | | | > | < | | < | | | > | | < | | < | > | | | < < | < < < < < < < > | | > | | | | | > | > | < < > | > | | > | < | > > > > > | | > > > | < > > | | | | > | < > | > > | > > | | > | | > > > | | | < > > | | > > > | > > > | | < < < | | | | > > > > > | | | > | | | | | > | > > | > | | | | | | > > | | > > > > > > | | > > > > > > > > > | | > > > > > > > > > > > > > > > > > | | | | | > | > | > > > > | > > | > | > | | | | | > | | | > > | | | > > > > > > > > > | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 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 |
.QW "channel busy"
error.
.RE
.\" METHOD: create
.TP
\fBchan create \fImode cmdPrefix\fR
.
This subcommand creates a new script level channel using the command
prefix \fIcmdPrefix\fR as its handler. Any such channel is called a
\fBreflected\fR channel. The specified command prefix, \fBcmdPrefix\fR,
must be a non-empty list, and should provide the API described in the
\fBrefchan\fR manual page. The handle of the new channel is
returned as the result of the \fBchan create\fR command, and the
channel is open. Use either \fBclose\fR or \fBchan close\fR to remove
the channel.
.RS
.PP
The argument \fImode\fR specifies if the new channel is opened for
reading, writing, or both. It has to be a list containing any of the
strings
.QW \fBread\fR
or
.QW \fBwrite\fR ,
The list must have at least one
element, as a channel you can neither write to nor read from makes no
sense. The handler command for the new channel must support the chosen
mode, or an error is thrown.
.PP
The command prefix is executed in the global namespace, at the top of
call stack, following the appending of arguments as described in the
\fBrefchan\fR manual page. Command resolution happens at the
time of the call. Renaming the command, or destroying it means that
the next call of a handler method may fail, causing the channel
command invoking the handler to fail as well. Depending on the
subcommand being invoked, the error message may not be able to explain
the reason for that failure.
.PP
Every channel created with this subcommand knows which interpreter it
was created in, and only ever executes its handler command in that
interpreter, even if the channel was shared with and/or was moved into
a different interpreter. Each reflected channel also knows the thread
it was created in, and executes its handler command only in that
thread, even if the channel was moved into a different thread. To this
end all invocations of the handler are forwarded to the original
thread by posting special events to it. This means that the original
thread (i.e. the thread that executed the \fBchan create\fR command)
must have an active event loop, i.e. it must be able to process such
events. Otherwise the thread sending them will \fIblock
indefinitely\fR. Deadlock may occur.
.PP
Note that this permits the creation of a channel whose two endpoints
live in two different threads, providing a stream-oriented bridge
between these threads. In other words, we can provide a way for
regular stream communication between threads instead of having to send
commands.
.PP
When a thread or interpreter is deleted, all channels created with
this subcommand and using this thread/interpreter as their computing
base are deleted as well, in all interpreters they have been shared
with or moved into, and in whatever thread they have been transferred
to. While this pulls the rug out under the other thread(s) and/or
interpreter(s), this cannot be avoided. Trying to use such a channel
will cause the generation of a regular error about unknown channel
handles.
.PP
This subcommand is \fBsafe\fR and made accessible to safe
interpreters. While it arranges for the execution of arbitrary Tcl
code the system also makes sure that the code is always executed
within the safe interpreter.
.RE
.\" METHOD: eof
.TP
\fBchan eof \fIchannel\fR
.
Test whether the last input operation on the channel called
\fIchannel\fR failed because the end of the data stream was reached,
returning 1 if end-of-file was reached, and 0 otherwise.
.\" METHOD: event
.TP
\fBchan event \fIchannel event\fR ?\fIscript\fR?
.
Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile
event handler\fR to be called whenever the channel called
\fIchannel\fR enters the state described by \fIevent\fR (which must
be either \fBreadable\fR or \fBwritable\fR); only one such handler may
be installed per event per channel at a time. If \fIscript\fR is the
empty string, the current handler is deleted (this also happens if the
channel is closed or the interpreter deleted). If \fIscript\fR is
omitted, the currently installed script is returned (or an empty
string if no such handler is installed). The callback is only
performed if the event loop is being serviced (e.g. via \fBvwait\fR or
\fBupdate\fR).
.RS
.PP
A file event handler is a binding between a channel and a script, such
that the script is evaluated whenever the channel becomes readable or
writable. File event handlers are most commonly used to allow data to
be received from another process on an event-driven basis, so that the
receiver can continue to interact with the user or with other channels
while waiting for the data to arrive. If an application invokes
\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is
no input data available, the process will block; until the input data
arrives, it will not be able to service other events, so it will
appear to the user to
.QW "freeze up"
\&.
With \fBchan event\fR, the
process can tell when data is present and only invoke \fBchan gets\fR
or \fBchan read\fR when they will not block.
.PP
A channel is considered to be readable if there is unread data
available on the underlying device. A channel is also considered to
be readable if there is unread data in an input buffer, except in the
special case where the most recent attempt to read from the channel
was a \fBchan gets\fR call that could not find a complete line in the
input buffer. This feature allows a file to be read a line at a time
in non-blocking mode using events. A channel is also considered to be
readable if an end of file or error condition is present on the
underlying file or device. It is important for \fIscript\fR to check
for these conditions and handle them appropriately; for example, if
there is no special check for end of file, an infinite loop may occur
where \fIscript\fR reads no data, returns, and is immediately invoked
again.
.PP
A channel is considered to be writable if at least one byte of data
can be written to the underlying file or device without blocking, or
if an error condition is present on the underlying file or device.
Note that client sockets opened in asynchronous mode become writable
when they become connected or if the connection fails.
.PP
Event-driven I/O works best for channels that have been placed into
non-blocking mode with the \fBchan configure\fR command. In blocking
mode, a \fBchan puts\fR command may block if you give it more data
than the underlying file or device can accept, and a \fBchan gets\fR
or \fBchan read\fR command will block if you attempt to read more data
than is ready; no events will be processed while the commands block.
In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan
gets\fR never block.
.PP
The script for a file event is executed at global level (outside the
context of any Tcl procedure) in the interpreter in which the \fBchan
event\fR command was invoked. If an error occurs while executing the
script then the command registered with \fBinterp bgerror\fR is used
to report the error. In addition, the file event handler is deleted
if it ever returns an error; this is done in order to prevent infinite
loops due to buggy handlers.
.RE
.\" METHOD: flush
.TP
\fBchan flush \fIchannel\fR
.
Ensures that all pending output for the channel called \fIchannel\fR
is written.
.RS
.PP
If the channel is in blocking mode the command does not return until
all the buffered output has been flushed to the channel. If the
channel is in non-blocking mode, the command may return before all
buffered output has been flushed; the remainder will be flushed in the
background as fast as the underlying file or device is able to absorb
it.
.RE
.\" METHOD: gets
.TP
\fBchan gets \fIchannel\fR ?\fIvarName\fR?
.
Reads a line from the channel consisting of all characters up to the next
end-of-line sequence or until end of file is seen. The line feed character
corresponding to end-of-line sequence is not included as part of the line.
If the \fIvarName\fR argument is specified, the line is stored in the variable
of that name and the command returns the length of the line. If \fIvarName\fR
is not specified, the command returns the line itself as the result of the command.
.RS
.PP
If a complete line is not available and the channel is not at EOF, the command
will block in the case of a blocking channel. For non-blocking channels, the
command will return the empty string as the result in the case of \fIvarName\fR
not specified and -1 if it is.
.RE
.RS
.PP
If a blocking channel is already at EOF, the command returns an empty string if
\fIvarName\fR is not specified. Note an empty string result can also be returned
when a blank line (no characters before the next end of line sequence). The two
cases can be distinguished by calling the \fBchan eof\fR command to check for
end of file. If \fIvarName\fR is specified, the command returns -1 on end of file.
There is no ambiguity in this case because blank lines result in 0 being returned.
.RE
.RS
.PP
If a non-blocking channel is already at EOF, the command returns an empty line
if \fIvarName\fR is not specified. This can be distinguished from an empty line
being returned by either a blank line being read or a full line not being available
through the use of the \fBchan eof\fR and \fBchan blocked\fR commands. If
\fBchan eof\fR returns true, the channel is at EOF. If \fBchan blocked\fR returns
true, a full line was not available. If both commands return false, an empty
line was read. If \fIvarName\fR was specified for a non-bocking channel at EOF,
the command returns -1. This can be distinguished from full line not being
available either by \fBchan eof\fR or \fBchan blocked\fR as above. Note that
when \fIvarName\fR is specified, there is no need to distinguish between eof
and blank lines as the latter will result in the command returning 0.
.PP
If the encoding profile \fBstrict\fR is in effect for the channel, the command
will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding
errors are encountered in the channel input data. The file pointer remains
unchanged and it is possible to introspect, and in some cases recover, by
changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later.
.RE
.\" METHOD: isbinary
.TP
\fBchan isbinary \fIchannel\fR
.
Test whether the channel called \fIchannel\fR is a binary channel,
returning 1 if it is and, and 0 otherwise. A binary channel is
a channel with iso8859-1 encoding, -eofchar set to {} and
-translation set to lf.
.\" METHOD: names
.TP
\fBchan names\fR ?\fIpattern\fR?
.
Produces a list of all channel names. If \fIpattern\fR is specified,
only those channel names that match it (according to the rules of
\fBstring match\fR) will be returned.
.\" METHOD: pending
.TP
\fBchan pending \fImode channel\fR
.
Depending on whether \fImode\fR is \fBinput\fR or \fBoutput\fR,
returns the number of
bytes of input or output (respectively) currently buffered
internally for \fIchannel\fR (especially useful in a readable event
callback to impose application-specific limits on input line lengths to avoid
a potential denial-of-service attack where a hostile user crafts
an extremely long line that exceeds the available memory to buffer it).
Returns -1 if the channel was not opened for the mode in question.
.\" METHOD: pipe
.TP
\fBchan pipe\fR
.
Creates a standalone pipe whose read- and write-side channels are
returned as a 2-element list, the first element being the read side and
the second the write side. Can be useful e.g. to redirect
separately \fBstderr\fR and \fBstdout\fR from a subprocess. To do
this, spawn with "2>@" or
">@" redirection operators onto the write side of a pipe, and then
immediately close it in the parent. This is necessary to get an EOF on
the read side once the child has exited or otherwise closed its output.
.RS
.PP
Note that the pipe buffering semantics can vary at the operating system level
substantially; it is not safe to assume that a write performed on the output
side of the pipe will appear instantly to the input side. This is a
fundamental difference and Tcl cannot conceal it. The overall stream semantics
\fIare\fR compatible, so blocking reads and writes will not see most of the
differences, but the details of what exactly gets written when are not. This
is most likely to show up when using pipelines for testing; care should be
taken to ensure that deadlocks do not occur and that potential short reads are
allowed for.
.RE
.\" METHOD: pop
.TP
\fBchan pop \fIchannel\fR
.
Removes the topmost transformation from the channel \fIchannel\fR, if there
is any. If there are no transformations added to \fIchannel\fR, this is
equivalent to \fBchan close\fR of that channel. The result is normally the
empty string, but can be an error in some situations (i.e. where the
underlying system stream is closed and that results in an error).
.\" METHOD: postevent
.TP
\fBchan postevent \fIchannel eventSpec\fR
.
This subcommand is used by command handlers specified with \fBchan
create\fR. It notifies the channel represented by the handle
\fIchannel\fR that the event(s) listed in the \fIeventSpec\fR have
occurred. The argument has to be a list containing any of the strings
\fBread\fR and \fBwrite\fR. The list must contain at least one
element as it does not make sense to invoke the command if there are
no events to post.
.RS
.PP
Note that this subcommand can only be used with channel handles that
were created/opened by \fBchan create\fR. All other channels will
cause this subcommand to report an error.
.PP
As only the Tcl level of a channel, i.e. its command handler, should
post events to it we also restrict the usage of this command to the
interpreter that created the channel. In other words, posting events
to a reflected channel from an interpreter that does not contain it's
implementation is not allowed. Attempting to post an event from any
other interpreter will cause this subcommand to report an error.
.PP
Another restriction is that it is not possible to post events that the
I/O core has not registered an interest in. Trying to do so will cause
the method to throw an error. See the command handler method
\fBwatch\fR described in \fBrefchan\fR, the document specifying
the API of command handlers for reflected channels.
.PP
This command is \fBsafe\fR and made accessible to safe interpreters.
It can trigger the execution of \fBchan event\fR handlers, whether in the
current interpreter or in other interpreters or other threads, even
where the event is posted from a safe interpreter and listened for by
a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR
executed in the interpreter that set them up.
.RE
.\" METHOD: push
.TP
\fBchan push \fIchannel cmdPrefix\fR
.
Adds a new transformation on top of the channel \fIchannel\fR. The
\fIcmdPrefix\fR argument describes a list of one or more words which represent
a handler that will be used to implement the transformation. The command
prefix must provide the API described in the \fBtranschan\fR manual page.
The result of this subcommand is a handle to the transformation. Note that it
is important to make sure that the transformation is capable of supporting the
channel mode that it is used with or this can make the channel neither
readable nor writable.
.\" METHOD: puts
.TP
\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannel\fR? \fIstring\fR
.
Writes \fIstring\fR to the channel named \fIchannel\fR followed by a
newline character. A trailing newline character is written unless the
optional flag \fB\-nonewline\fR is given. If \fIchannel\fR is
omitted, the string is written to the standard output channel,
\fBstdout\fR.
.RS
.PP
Newline characters in the output are translated by \fBchan puts\fR to
platform-specific end-of-line sequences according to the currently
configured value of the \fB\-translation\fR option for the channel
(for example, on PCs newlines are normally replaced with
carriage-return-linefeed sequences; see \fBchan configure\fR above for
details).
.PP
Tcl buffers output internally, so characters written with \fBchan
puts\fR may not appear immediately on the output file or device; Tcl
will normally delay output until the buffer is full or the channel is
closed. You can force output to appear immediately with the \fBchan
flush\fR command.
.PP
When the output buffer fills up, the \fBchan puts\fR command will
normally block until all the buffered data has been accepted for
output by the operating system. If \fIchannel\fR is in non-blocking
mode then the \fBchan puts\fR command will not block even if the
operating system cannot accept the data. Instead, Tcl continues to
buffer the data and writes it in the background as fast as the
underlying file or device can accept it. The application must use the
Tcl event loop for non-blocking output to work; otherwise Tcl never
finds out that the file or device is ready for more output data. It
is possible for an arbitrarily large amount of data to be buffered for
a channel in non-blocking mode, which could consume a large amount of
memory. To avoid wasting memory, non-blocking I/O should normally be
used in an event-driven fashion with the \fBchan event\fR command
(do not invoke \fBchan puts\fR unless you have recently been notified
via a file event that the channel is ready for more output data).
.PP
The command will raise an error exception with POSIX error code \fBEILSEQ\fR if
the encoding profile \fBstrict\fR is in effect for the channel and the output
data cannot be encoded in the encoding configured for the channel. Data
may be partially written to the channel in this case.
.RE
.\" METHOD: read
.TP
\fBchan read \fIchannel\fR ?\fInumChars\fR?
.TP
\fBchan read \fR?\fB\-nonewline\fR? \fIchannel\fR
.
In the first form, the result will be the next \fInumChars\fR
characters read from the channel named \fIchannel\fR; if
\fInumChars\fR is omitted, all characters up to the point when the
channel would signal a failure (whether an end-of-file, blocked or
other error condition) are read. In the second form (i.e. when
\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be
given to indicate that any trailing newline in the string that has
been read should be trimmed.
.RS
.PP
If \fIchannel\fR is in non-blocking mode, \fBchan read\fR may not
read as many characters as requested: once all available input has
been read, the command will return the data that is available rather
than blocking for more input. If the channel is configured to use a
multi-byte encoding, then there may actually be some bytes remaining
in the internal buffers that do not form a complete character. These
bytes will not be returned until a complete character is available or
end-of-file is reached. The \fB\-nonewline\fR switch is ignored if
the command returns before reaching the end of the file.
.PP
\fBChan read\fR translates end-of-line sequences in the input into
newline characters according to the \fB\-translation\fR option for the
channel (see \fBchan configure\fR above for a discussion on the ways
in which \fBchan configure\fR will alter input).
.PP
When reading from a serial port, most applications should configure
the serial port channel to be non-blocking, like this:
.PP
.CS
\fBchan configure \fIchannel \fB\-blocking \fI0\fR.
.CE
.PP
Then \fBchan read\fR behaves much like described above. Note that
most serial ports are comparatively slow; it is entirely possible to
get a \fBreadable\fR event for each character read from them. Care
must be taken when using \fBchan read\fR on blocking serial ports:
.TP
\fBchan read \fIchannel numChars\fR
.
In this form \fBchan read\fR blocks until \fInumChars\fR have been
received from the serial port.
.TP
\fBchan read \fIchannel\fR
.
In this form \fBchan read\fR blocks until the reception of the
end-of-file character, see \fBchan configure -eofchar\fR. If there no
end-of-file character has been configured for the channel, then
\fBchan read\fR will block forever.
.PP
If the encoding profile \fBstrict\fR is in effect for the channel, the command
will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding
errors are encountered in the channel input data. If the channel is in blocking
mode, the error is thrown after advancing the file pointer to the beginning of
the invalid data. The successfully decoded leading portion of the data prior to
the error location is returned as the value of the \fB\-data\fR key of the error
option dictionary. If the channel is in non-blocking mode, the successfully
decoded portion of data is returned by the command without an error
exception being raised. A subsequent read will start at the invalid data
and immediately raise a \fBEILSEQ\fR POSIX error exception. Unlike the
blocking channel case, the \fB\-data\fR key is not present in the
error option dictionary. In the case of exception thrown due to encoding
errors, it is possible to introspect, and in some cases recover, by
changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later.
.RE
.\" METHOD: seek
.TP
\fBchan seek \fIchannel offset\fR ?\fIorigin\fR?
.
Sets the current access position within the underlying data stream for
the channel named \fIchannel\fR to be \fIoffset\fR bytes relative to
\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative)
and \fIorigin\fR must be one of the following:
.RS
.IP \fBstart\fR
The new access position will be \fIoffset\fR bytes from the start
of the underlying file or device.
.IP \fBcurrent\fR
The new access position will be \fIoffset\fR bytes from the current
access position; a negative \fIoffset\fR moves the access position
backwards in the underlying file or device.
.IP \fBend\fR
The new access position will be \fIoffset\fR bytes from the end of the
file or device. A negative \fIoffset\fR places the access position
before the end of file, and a positive \fIoffset\fR places the access
position after the end of file.
.PP
The \fIorigin\fR argument defaults to \fBstart\fR.
.PP
\fBChan seek\fR flushes all buffered output for the channel before the
command returns, even if the channel is in non-blocking mode. It also
discards any buffered and unread input. This command returns an empty
string. An error occurs if this command is applied to channels whose
underlying file or device does not support seeking.
.PP
Note that \fIoffset\fR values are byte offsets, not character offsets.
Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes,
not characters, unlike \fBchan read\fR.
.RE
.\" METHOD: tell
.TP
\fBchan tell \fIchannel\fR
.
Returns a number giving the current access position within the
underlying data stream for the channel named \fIchannel\fR. This
value returned is a byte offset that can be passed to \fBchan seek\fR
in order to set the channel to a particular position. Note that this
value is in terms of bytes, not characters like \fBchan read\fR. The
value returned is -1 for channels that do not support seeking.
.\" METHOD: truncate
.TP
\fBchan truncate \fIchannel\fR ?\fIlength\fR?
.
Sets the byte length of the underlying data stream for the channel
named \fIchannel\fR to be \fIlength\fR (or to the current byte
offset within the underlying data stream if \fIlength\fR is
omitted). The channel is flushed before truncation.
.
.SH EXAMPLES
.SS "SIMPLE CHANNEL OPERATION EXAMPLES"
.PP
Instruct Tcl to always send output to \fBstdout\fR immediately,
whether or not it is to a terminal:
.PP
.CS
\fBfconfigure\fR stdout -buffering none
.CE
.PP
In the following example a file is opened using the encoding CP1252, which is
common on Windows, searches for a string, rewrites that part, and truncates the
file two lines later.
.PP
.CS
set f [open somefile.txt r+]
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 637 638 639 640 641 642 |
}
\fI# Save offset of start of next line for later\fR
set offset [\fBchan tell\fR $f]
}
\fBchan close\fR $f
.CE
.PP
A network server that echoes its input line-by-line without
preventing servicing of other connections at the same time:
.PP
.CS
# This is a very simple logger...
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
}
\fI# Save offset of start of next line for later\fR
set offset [\fBchan tell\fR $f]
}
\fBchan close\fR $f
.CE
.PP
This example illustrates flushing of a channel. The user is
prompted for some information. Because the standard input channel
is line buffered, it must be flushed for the user to see the prompt.
.PP
.CS
chan puts -nonewline "Please type your name: "
\fBchan flush\fR stdout
chan gets stdin name
chan puts "Hello there, $name!"
.CE
.PP
This example reads a file one line at a time and prints it out with
the current line number attached to the start of each line.
.PP
.CS
set chan [open "some.file.txt"]
set lineNumber 0
while {[\fBchan gets\fR $chan line] >= 0} {
chan puts "[incr lineNumber]: $line"
}
chan close $chan
.CE
.PP
In this example illustrating event driven reads,
\fBGetData\fR will be called with the channel as an
argument whenever $chan becomes readable. The \fBread\fR call will
read whatever binary data is currently available without blocking.
Here the channel has the fileevent removed when an end of file
occurs to avoid being continually called (see above). Alternatively
the channel may be closed on this condition.
.PP
.CS
proc GetData {chan} {
set data [chan read $chan]
chan puts "[string length $data] $data"
if {[chan eof $chan]} {
chan event $chan readable {}
}
}
chan configure $chan -blocking 0 -translation binary
\fBchan event\fR $chan readable [list GetData $chan]
.CE
.PP
The next example is similar but uses \fBchan gets\fR to read
line-oriented data.
.PP
.CS
proc GetData {chan} {
if {[chan gets $chan line] >= 0} {
chan puts $line
}
if {[chan eof $chan]} {
chan close $chan
}
}
chan configure $chan -blocking 0 -buffering line -translation crlf
\fBchan event\fR $chan readable [list GetData $chan]
.CE
.PP
A network server that echoes its input line-by-line without
preventing servicing of other connections at the same time:
.PP
.CS
# This is a very simple logger...
proc log {message} {
\fBchan puts\fR stdout $message
}
# This is called whenever a new client connects to the server
proc connect {chan host port} {
set clientName [format <%s:%d> $host $port]
log "connection from $clientName"
|
| ︙ | ︙ | |||
667 668 669 670 671 672 673 674 675 676 677 678 679 680 | } # Create the server socket and enter the event-loop to wait # for incoming connections... socket -server connect 12345 vwait forever .CE .SS "CHANNEL COPY 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 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
# Create the server socket and enter the event-loop to wait
# for incoming connections...
socket -server connect 12345
vwait forever
.CE
.PP
The following example reads a PPM-format image from a file
combining ASCII and binary content.
.PP
.CS
# Open the file and put it into Unix ASCII mode
set f [open teapot.ppm]
\fBchan configure\fR $f -encoding ascii -translation lf
# Get the header
if {[chan gets $f] ne "P6"} {
error "not a raw\-bits PPM"
}
# Read lines until we have got non-comment lines
# that supply us with three decimal values.
set words {}
while {[llength $words] < 3} {
chan gets $f line
if {[string match "#*" $line]} continue
lappend words {*}[join [scan $line %d%d%d]]
}
# Those words supply the size of the image and its
# overall depth per channel. Assign to variables.
lassign $words xSize ySize depth
# Now switch to binary mode to pull in the data,
# one byte per channel (red,green,blue) per pixel.
\fBchan configure\fR $f -translation binary
set numDataBytes [expr {3 * $xSize * $ySize}]
set data [chan read $f $numDataBytes]
close $f
.CE
.SS "FILE SEEK EXAMPLES"
.PP
Read a file twice:
.PP
.CS
set f [open file.txt]
set data1 [chan read $f]
\fBchan seek\fR $f 0
set data2 [chan read $f]
chan close $f
# $data1 eq $data2 if the file wasn't updated
.CE
.PP
Read the last 10 bytes from a file:
.PP
.CS
set f [open file.data]
# This is guaranteed to work with binary data but
# may fail with other encodings...
chan configure $f -translation binary
\fBchan seek\fR $f -10 end
set data [chan read $f 10]
chan close $f
.CE
.PP
Read a line from a file channel only if it starts with \fBfoobar\fR:
.PP
.CS
# Save the offset in case we need to undo the read...
set offset [\fBtell\fR $chan]
if {[read $chan 6] eq "foobar"} {
gets $chan line
} else {
set line {}
# Undo the read...
seek $chan $offset
}
.CE
.SS "ENCODING ERROR EXAMPLES"
.PP
The example below illustrates handling of an encoding error encountered
during channel input. First, creation of a test file containing
the invalid UTF-8 sequence (\fBA \\xC3 B\fR):
.PP
.CS
% set f [open test_A_195_B.txt wb]; chan puts -nonewline $f A\\xC3B; chan close $f
.CE
.PP
An attempt to read the file will result in an encoding error which is
then introspected by switching the channel to binary mode. Note in the
example that when the error is reported the file position remains
unchanged so that the \fBchan gets\fR during recovery returns the
full line.
.PP
.CS
% set f [open test_A_195_B.txt r]
file384b6a8
% chan configure $f -encoding utf-8
% catch {chan gets $f} e d
1
% set d
-code 1 -level 0
-errorstack {INNER {invokeStk1 gets file384b6a8}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
0
% chan configure $f -translation binary
% chan gets $f
AÃB
.CE
.PP
The following example is similar to the above but demonstrates recovery after a
blocking read. The successfully decoded data "A" is returned in the error options
dictionary key \fB\-data\fR. The file position is advanced on the encoding error
position 1. The data at the error position is thus recovered by the next
\fBchan read\fR command.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -blocking 1
% catch {chan read $f} e d
1
% set d
-data A -code 1 -level 0
-errorstack {INNER {invokeStk1 read file35a65a0}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
1
% chan configure $f -translation binary
% chan read $f
ÃB
% chan close $f
.CE
.PP
Finally the same example, but this time with a non-blocking channel.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -blocking 0
% chan read $f
A
% chan tell $f
1
% catch {chan read $f} e d
1
% set d
-code 1 -level 0
-errorstack {INNER {invokeStk1 read file384b228}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
.CE
.SS "CHANNEL COPY 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
|
| ︙ | ︙ | |||
754 755 756 757 758 759 760 | \fBchan copy\fR $sok1 $sok2 -command [list Done UP] \fBchan copy\fR $sok2 $sok1 -command [list Done DOWN] vwait done .CE .SH "SEE ALSO" close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), | | > > | | 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 | \fBchan copy\fR $sok1 $sok2 -command [list Done UP] \fBchan copy\fR $sok2 $sok1 -command [list Done DOWN] vwait done .CE .SH "SEE ALSO" close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), socket(n), tell(n), refchan(n), transchan(n), Tcl_StandardChannels(3) .SH KEYWORDS blocking, channel, end of file, events, input, non-blocking, offset, output, readable, seek, stdio, tell, writable '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/class.n.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | \fIcls \fBcreateWithNamespace\fI name nsName\fR ?\fIarg ...\fR? . This creates a new instance of the class \fIcls\fR called \fIname\fR (which is resolved within the calling context's namespace if not fully qualified), passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns a successful result) returning the fully qualified name of the created object (the result of the constructor is ignored). The name of the instance's | | > > > | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | \fIcls \fBcreateWithNamespace\fI name nsName\fR ?\fIarg ...\fR? . This creates a new instance of the class \fIcls\fR called \fIname\fR (which is resolved within the calling context's namespace if not fully qualified), passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns a successful result) returning the fully qualified name of the created object (the result of the constructor is ignored). The name of the instance's internal namespace will be \fInsName\fR; .VS it is an error if that namespace cannot be created. .VE If the constructor fails (i.e., returns a non-OK result) then the object is destroyed and the error message is the result of this method call. .SH EXAMPLES .PP This example defines a simple class hierarchy and creates a new instance of it. It then invokes a method of the object before destroying the hierarchy and showing that the destruction is transitive. |
| ︙ | ︙ |
Changes to doc/clock.n.
| ︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 110 | 1 January 1970, 00:00 UTC. Note that the count of seconds does not include any leap seconds; seconds are counted as if each UTC day has exactly 86400 seconds. Tcl responds to leap seconds by speeding or slowing its clock by a tiny fraction for some minutes until it is back in sync with UTC; its data model does not represent minutes that have 59 or 61 seconds. .TP \fIunit\fR . One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR, \fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. Used in conjunction with \fIcount\fR to identify an interval of time, for example, \fI3 seconds\fR or \fI1 year\fR. .SS "OPTIONS" | > > > > > > > > > | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | 1 January 1970, 00:00 UTC. Note that the count of seconds does not include any leap seconds; seconds are counted as if each UTC day has exactly 86400 seconds. Tcl responds to leap seconds by speeding or slowing its clock by a tiny fraction for some minutes until it is back in sync with UTC; its data model does not represent minutes that have 59 or 61 seconds. .TP \fInow\fR Instead of \fItimeVal\fR a non-integer value \fBnow\fR can be used as replacement for today, which is simply interpolated to the run-time as value of \fBclock seconds\fR. For example: .sp \fBclock format now -f %a; # current day of the week\fR .sp \fBclock add now 1 month; # next month\fR .TP \fIunit\fR . One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR, \fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. Used in conjunction with \fIcount\fR to identify an interval of time, for example, \fI3 seconds\fR or \fI1 year\fR. .SS "OPTIONS" |
| ︙ | ︙ | |||
119 120 121 122 123 124 125 | .TP \fB\-format\fR format . Specifies the desired output format for \fBclock format\fR or the expected input format for \fBclock scan\fR. The \fIformat\fR string consists of any number of characters other than the per-cent sign .PQ \fB%\fR | | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | .TP \fB\-format\fR format . Specifies the desired output format for \fBclock format\fR or the expected input format for \fBclock scan\fR. The \fIformat\fR string consists of any number of characters other than the per-cent sign .PQ \fB%\fR interspersed with any number of \fIformat groups\fR, which are two- or three-character sequences beginning with the per-cent sign. The permissible format groups, and their interpretation, are described under \fBFORMAT GROUPS\fR. .RS .PP On \fBclock format\fR, the default format is .PP .CS |
| ︙ | ︙ | |||
181 182 183 184 185 186 187 188 189 190 191 192 193 194 | .IP [1] the environment variable \fBTCL_TZ\fR. .IP [2] the environment variable \fBTZ\fR. .IP [3] on Windows systems, the time zone settings from the Control Panel. .RE .PP If none of these is present, the C \fBlocaltime\fR and \fBmktime\fR functions are used to attempt to convert times between local and Greenwich. On 32-bit systems, this approach is likely to have bugs, particularly for times that lie outside the window (approximately the years 1902 to 2037) that can be represented in a 32-bit integer. .SH "CLOCK ARITHMETIC" | > > > > > > > > > | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | .IP [1] the environment variable \fBTCL_TZ\fR. .IP [2] the environment variable \fBTZ\fR. .IP [3] on Windows systems, the time zone settings from the Control Panel. .RE .\" OPTION: -validate .TP \fB\-validate\fR boolean . If \fIboolean\fR is true (default), \fBclock scan\fR will raise an error if the input contains invalid values, e.g. day of month greater than number of days in the month. If specified as false, the command makes an adjustment to bring values within acceptable range. See \fBSCANNING TIMES\fR for details. .PP If none of these is present, the C \fBlocaltime\fR and \fBmktime\fR functions are used to attempt to convert times between local and Greenwich. On 32-bit systems, this approach is likely to have bugs, particularly for times that lie outside the window (approximately the years 1902 to 2037) that can be represented in a 32-bit integer. .SH "CLOCK ARITHMETIC" |
| ︙ | ︙ | |||
409 410 411 412 413 414 415 | .PP The date is determined according to the fields that are present in the preprocessed format string. In order of preference: .IP [1] If the string contains a \fB%s\fR format group, representing seconds from the epoch, that group is used to determine the date. .IP [2] | | > | > > > | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | .PP The date is determined according to the fields that are present in the preprocessed format string. In order of preference: .IP [1] If the string contains a \fB%s\fR format group, representing seconds from the epoch, that group is used to determine the date. .IP [2] If the string contains a \fB%J\fR, \fB%EJ\fR or \fB%Ej\fR format groups, representing the Calendar or Astronomical Julian Day Number, that groups are used to determine the date. Note, that in case of \fB%EJ\fR or \fB%Ej\fR format groups, representing the Julian Date with time fraction, this groups may be used to determine the date and time. .IP [3] If the string contains a complete set of format groups specifying century, year, month, and day of month; century, year, and day of year; or ISO8601 fiscal year, week of year, and day of week; those groups are combined and used to determine the date. If more than one complete set is present, the one at the rightmost position in the string is used. |
| ︙ | ︙ | |||
475 476 477 478 479 480 481 | in the same day, once without and once with Daylight Saving Time. If this situation occurs, the first occurrence of the time is chosen. (For this reason, it is wise to have the input string contain the time zone when converting local times. This caveat does not apply to UTC times.) .PP If the interpretation of the groups yields an impossible time because | > > | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 | in the same day, once without and once with Daylight Saving Time. If this situation occurs, the first occurrence of the time is chosen. (For this reason, it is wise to have the input string contain the time zone when converting local times. This caveat does not apply to UTC times.) .PP If the interpretation of the groups yields an impossible time because a field is out of range, an exception is raised if the \fB-validate\fR option is not present or passed as true. If passed as false, enough of that field's unit will be added to or subtracted from the time to bring it in range. Thus, if attempting to scan or format day 0 of the month, one day will be subtracted from day 1 of the month, yielding the last day of the previous month. .PP If the interpretation of the groups yields an impossible time because a Daylight Saving Time change skips over that time, or an ambiguous time because a Daylight Saving Time change skips back so that the clock |
| ︙ | ︙ | |||
548 549 550 551 552 553 554 555 556 557 558 559 560 561 | On output, produces the string \fBB.C.E.\fR or \fBC.E.\fR, or a string of the same meaning in the locale, to indicate whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. On input, accepts the string \fBB.C.E.\fR, \fBB.C.\fR, \fBC.E.\fR, \fBA.D.\fR, or the abbreviation appropriate to the current locale, and uses it to fix whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. .IP \fB%Ex\fR On output, produces a locale-dependent representation of the date in the locale's alternative calendar. On input, matches whatever \fB%Ex\fR produces. The locale's alternative calendar need not be the Gregorian calendar. .IP \fB%EX\fR On output, produces a locale-dependent representation of the | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | On output, produces the string \fBB.C.E.\fR or \fBC.E.\fR, or a string of the same meaning in the locale, to indicate whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. On input, accepts the string \fBB.C.E.\fR, \fBB.C.\fR, \fBC.E.\fR, \fBA.D.\fR, or the abbreviation appropriate to the current locale, and uses it to fix whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. .IP \fB%Ej\fR On output, produces a string of digits giving the Astronomical Julian Date or Astronomical Julian Day Number (JDN/JD). In opposite to calendar julian day \fB%J\fR, it starts the day at noon. On input, accepts a string of digits (or floating point with the time fraction) and interprets it as an Astronomical Julian Day Number (JDN/JD). The Astronomical Julian Date is a count of the number of calendar days that have elapsed since 1 January, 4713 BCE of the proleptic Julian calendar, which contains also the time fraction (after floating point). The epoch time of 1 January 1970 corresponds to Astronomical JDN 2440587.5. This value corresponds the julian day used in sqlite-database, and is the same as result of \fBselect julianday(:seconds, 'unixepoch')\fR. .IP \fB%EJ\fR On output, produces a string of digits giving the Calendar Julian Date. In opposite to julian day \fB%J\fR format group, it produces float number. In opposite to astronomical julian day \fB%Ej\fR group, it starts at midnight. On input, accepts a string of digits (or floating point with the time fraction) and interprets it as a Calendar Julian Day Number. The Calendar Julian Date is a count of the number of calendar days that have elapsed since 1 January, 4713 BCE of the proleptic Julian calendar, which contains also the time fraction (after floating point). The epoch time of 1 January 1970 corresponds to Astronomical JDN 2440588. .IP \fB%Es\fR This affects similar to \fB%s\fR, but in opposition to \fB%s\fR it parses or formats local seconds (not the posix seconds). Because \fB%s\fR has the same precedence as \fB%s\fR (uniquely determines a point in time), it overrides all other input formats. .IP \fB%Ex\fR On output, produces a locale-dependent representation of the date in the locale's alternative calendar. On input, matches whatever \fB%Ex\fR produces. The locale's alternative calendar need not be the Gregorian calendar. .IP \fB%EX\fR On output, produces a locale-dependent representation of the |
| ︙ | ︙ | |||
708 709 710 711 712 713 714 | accepts four digits and may be used to determine calendar date. Note that \fB%Y\fR does not yield a year appropriate for use with the ISO8601 week number \fB%V\fR; programs should use \fB%G\fR for that purpose. .IP \fB%z\fR On output, produces the current time zone, expressed in hours and minutes east (+hhmm) or west (\-hhmm) of Greenwich. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to | | > > | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 | accepts four digits and may be used to determine calendar date. Note that \fB%Y\fR does not yield a year appropriate for use with the ISO8601 week number \fB%V\fR; programs should use \fB%G\fR for that purpose. .IP \fB%z\fR On output, produces the current time zone, expressed in hours and minutes east (+hhmm) or west (\-hhmm) of Greenwich. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to determine the time zone (this token is optionally applicable on input, so the value is not mandatory and can be missing in input). .IP \fB%Z\fR On output, produces the current time zone's name, possibly translated to the given locale. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to determine the time zone (token is also like \fB%z\fR optionally applicable on input). This option should, in general, be used on input only when parsing RFC822 dates. Other uses are fraught with ambiguity; for instance, the string \fBBST\fR may represent British Summer Time or Brazilian Standard Time. It is recommended that date/time strings for use by computers use numeric time zones instead. .IP \fB%%\fR On output, produces a literal .QW \fB%\fR |
| ︙ | ︙ | |||
775 776 777 778 779 780 781 | .PP If the time zone begins with a colon, it is one of a standardized list of names like \fB:America/New_York\fR that give the rules for various locales. A complete list of the location names is too lengthy to be listed here. On most Tcl installations, the definitions of the locations are to be found in named files in the directory | | | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 | .PP If the time zone begins with a colon, it is one of a standardized list of names like \fB:America/New_York\fR that give the rules for various locales. A complete list of the location names is too lengthy to be listed here. On most Tcl installations, the definitions of the locations are to be found in named files in the directory .QW "\fI/no_backup/tools/lib/tcl9.0/clock/tzdata\fR" . On some Unix systems, these files are omitted, and the definitions are instead obtained from system files in .QW "\fI/usr/share/zoneinfo\fR" , .QW "\fI/usr/share/lib/zoneinfo\fR" or .QW "\fI/usr/local/etc/zoneinfo\fR" . As a special case, the name \fB:localtime\fR refers to |
| ︙ | ︙ | |||
864 865 866 867 868 869 870 | \fItime\fR . A time of day, which is of the form: .QW "\fIhh\fR?\fB:\fImm\fR?\fB:\fIss\fR?? ?\fImeridian\fR? ?\fIzone\fR?" or .QW "\fBhhmm \fR?\fBmeridian\fR? ?\fBzone\fR?" . If no \fImeridian\fR is specified, \fIhh\fR is interpreted on | | > | | > > | 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 | \fItime\fR . A time of day, which is of the form: .QW "\fIhh\fR?\fB:\fImm\fR?\fB:\fIss\fR?? ?\fImeridian\fR? ?\fIzone\fR?" or .QW "\fBhhmm \fR?\fBmeridian\fR? ?\fBzone\fR?" . If no \fImeridian\fR is specified, \fIhh\fR is interpreted on a 24-hour clock. The "24:00" and "24:00:00" formats (with or without colon) are supported only if no \fImeridian\fR is specified. .TP \fIdate\fR . A specific month and day with optional year. The acceptable formats are .QW "\fImm\fB/\fIdd\fR?\fB/\fIyy\fR?" , .QW "\fImonthname dd\fR?\fB, \fIyy\fR?" , .QW "\fIday\fB, \fIdd monthname \fR?\fIyy\fR?" , .QW "\fIdd monthname yy\fR" , .QW "?\fICC\fR?\fIyymmdd\fR" , and .QW "\fIdd\fB-\fImonthname\fB-\fR?\fICC\fR?\fIyy\fR" . The default year is the current year. If the year is less than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR . An ISO 8601 point-in-time specification, such as .QW "\fICCyymmdd\fBT\fIhhmmss\fR" , where \fBT\fR is the literal .QW T , .QW "\fICCyymmdd hhmmss\fR" , .QW "\fICCyymmdd\fBT\fIhh:mm:ss\fR" , or .QW "\fICCyy-mm-dd\fBT\fIhh:mm:ss\fR" . Note that only these four formats are accepted. The command does \fInot\fR accept the full range of point-in-time specifications specified in ISO8601. For example, leap seconds are not supported. The "24:00" and "24:00:00" formats (with or without colon) are supported. Other formats can be recognized by giving an explicit \fB\-format\fR option to the \fBclock scan\fR command. .TP \fIrelative time\fR . A specification relative to the current time. The format is \fBnumber unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, |
| ︙ | ︙ | |||
918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 | Using that time as the base, day-of-week specifications are added. Next, relative specifications are used. If a date or day is specified, and no absolute or relative time is given, midnight is used. Finally, a correction is applied so that the correct hour of the day is produced after allowing for daylight savings time differences and the correct date is given when going from the end of a long month to a short month. .SH "SEE ALSO" msgcat(n) .SH KEYWORDS clock, date, time .SH "COPYRIGHT" Copyright \(co 2004 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" Local Variables: '\" mode: nroff '\" End: | > > > > > > > > > > > > > > > > > > | 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 | Using that time as the base, day-of-week specifications are added. Next, relative specifications are used. If a date or day is specified, and no absolute or relative time is given, midnight is used. Finally, a correction is applied so that the correct hour of the day is produced after allowing for daylight savings time differences and the correct date is given when going from the end of a long month to a short month. .PP The precedence of the applying of single tokens resp. which sequence will be used by calculating of the time is complex, e. g. heavily dependent on the precision of type of the token. .sp In example below the second date-string contains "next January", therefore it results in next year but in January. And third date-string besides "January" contains also additionally "Fri", so it results in the nearest Friday. Thus both win before "385 days" resp. make it more precise, because of higher precision of this token types. .CS % clock format [clock scan "5 years 18 months 385 days" -base 0 -gmt 1] -gmt 1 Thu Jul 21 00:00:00 GMT 1977 % clock format [clock scan "5 years 18 months 385 days next January" -base 0 -gmt 1] -gmt 1 Sat Jan 21 00:00:00 GMT 1978 % clock format [clock scan "5 years 18 months 385 days next January Fri" -base 0 -gmt 1] -gmt 1 Fri Jan 27 00:00:00 GMT 1978 .CE .SH "SEE ALSO" msgcat(n) .SH KEYWORDS clock, date, time .SH "COPYRIGHT" Copyright \(co 2004 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/close.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH close n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel .SH SYNOPSIS | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < | < < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | .TH close n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel .SH SYNOPSIS \fBclose \fIchannel\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)? .BE .SH DESCRIPTION .PP The \fBclose\fR command has been superceded by the \fBchan close\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/concat.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH concat n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME concat \- Join lists together .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH concat n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME concat \- Join lists together .SH SYNOPSIS \fBconcat\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command joins each of its arguments together with spaces after trimming leading and trailing white-space from each of them. If all of the arguments are lists, this has the same effect as concatenating them into a single list. |
| ︙ | ︙ |
Changes to doc/configurable.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2019 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH configurable n 0.4 TclOO "TclOO Commands" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/cookiejar.n.
| ︙ | ︙ | |||
185 186 187 188 189 190 191 | the start of the application. .PP .CS package require http \fBpackage require cookiejar\fR set cookiedb [file join [file home] cookiejar] | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 | the start of the application. .PP .CS package require http \fBpackage require cookiejar\fR set cookiedb [file join [file home] cookiejar] http::config -cookiejar [\fBhttp::cookiejar new\fR $cookiedb] # No further explicit steps are required to use cookies set tok [http::geturl http://core.tcl-lang.org/] .CE .PP To only allow a particular domain to use cookies, perhaps because you only want to enable a particular host to create and manipulate sessions, create a |
| ︙ | ︙ |
Changes to doc/coroutine.n.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 | with quite a bit of similarity to \fBcoroprobe\fR. However, with \fBcoroinject\fR there are several key differences: .VE "8.7, TIP383" .IP \(bu .VS "8.7, TIP383" The coroutine is not immediately resumed after the injection has been done. A consequence of this is that multiple injections may be done before the | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | with quite a bit of similarity to \fBcoroprobe\fR. However, with \fBcoroinject\fR there are several key differences: .VE "8.7, TIP383" .IP \(bu .VS "8.7, TIP383" The coroutine is not immediately resumed after the injection has been done. A consequence of this is that multiple injections may be done before the coroutine is resumed. The injected commands are performed in \fIreverse order of definition\fR (that is, they are internally stored on a stack). .VE "8.7, TIP383" .IP \(bu .VS "8.7, TIP383" An additional two arguments are appended to the list of arguments to be run (that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements). The first is the name of the command that suspended the coroutine (\fByield\fR |
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
\fIcollect\fR rst
# ==> Received 'rst' at a yield in ::collect
\fIcollect\fR xyz
puts [\fIcollect\fR]
# ==> 123 {abc def} 456 pqr RST xyz
.CE
| < < < < | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
\fIcollect\fR rst
# ==> Received 'rst' at a yield in ::collect
\fIcollect\fR xyz
puts [\fIcollect\fR]
# ==> 123 {abc def} 456 pqr RST xyz
.CE
.VE "8.7, TIP383"
.SS "DETAILED SEMANTICS"
.PP
This example demonstrates that coroutines start from the global namespace, and
that \fIcommand\fR resolution happens before the coroutine stack is created.
.PP
.CS
|
| ︙ | ︙ |
Changes to doc/define.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007-2018 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 define n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | '\" '\" Copyright (c) 2007-2018 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 define n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::define, oo::objdefine, oo::Slot \- define and configure classes and objects .SH SYNOPSIS .nf package require tcl::oo \fBoo::define\fI class defScript\fR \fBoo::define\fI class subcommand arg\fR ?\fIarg ...\fR? \fBoo::objdefine\fI object defScript\fR \fBoo::objdefine\fI object subcommand arg\fR ?\fIarg ...\fR? \fBoo::Slot\fR \fIarg...\fR .fi .SH "CLASS HIERARCHY" .nf \fBoo::object\fR \(-> \fBoo::Slot\fR .fi .BE .SH DESCRIPTION The \fBoo::define\fR command is used to control the configuration of classes, and the \fBoo::objdefine\fR command is used to control the configuration of objects (including classes as instance objects), with the configuration being applied to the entity named in the \fIclass\fR or the \fIobject\fR argument. |
| ︙ | ︙ | |||
510 511 512 513 514 515 516 | \fBself call\fR). .VE TIP500 .SH "SLOTTED DEFINITIONS" Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of | > > | | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | \fBself call\fR). .VE TIP500 .SH "SLOTTED DEFINITIONS" Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of the slot. .PP The \fBoo::Slot\fR class defines six operations (as methods) that may be done on the slot: .\" METHOD: -append .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? . This appends the given \fImember\fR elements to the slot definition. .\" METHOD: -appendifnew .TP |
| ︙ | ︙ | |||
550 551 552 553 554 555 556 557 558 559 560 561 562 563 | \fIslot\fR \fB\-set\fR ?\fImember ...\fR? . This replaces the slot definition with the given \fImember\fR elements. .PP A consequence of this is that any use of a slot's default operation where the first member argument begins with a hyphen will be an error. One of the above operations should be used explicitly in those circumstances. .SS "SLOT IMPLEMENTATION" .\" METHOD: --default-operation Internally, slot objects also define a method \fB\-\-default\-operation\fR which is forwarded to the default operation of the slot (thus, for the class .QW \fBvariable\fR slot, this is forwarded to .QW "\fBmy \-append\fR" ), | > > > > | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 | \fIslot\fR \fB\-set\fR ?\fImember ...\fR? . This replaces the slot definition with the given \fImember\fR elements. .PP A consequence of this is that any use of a slot's default operation where the first member argument begins with a hyphen will be an error. One of the above operations should be used explicitly in those circumstances. .PP You only need to make an instance of \fBoo::Slot\fR if you are definining your own slot that behaves like a standard slot. .PP .SS "SLOT IMPLEMENTATION" .\" METHOD: --default-operation Internally, slot objects also define a method \fB\-\-default\-operation\fR which is forwarded to the default operation of the slot (thus, for the class .QW \fBvariable\fR slot, this is forwarded to .QW "\fBmy \-append\fR" ), |
| ︙ | ︙ | |||
593 594 595 596 597 598 599 600 601 602 603 604 605 606 | require that values are resolvable to work). .RS .PP Implementations \fIshould not\fR enforce uniqueness and ordering constraints in this method; that is the responsibility of the \fBSet\fR method. .RE .VE TIP516 .\" METHOD: Set .TP \fIslot\fR \fBSet \fIelementList\fR . Sets the contents of the slot to the list \fIelementList\fR and returns the empty string. This method must always be called from a stack frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an | > > > > > > > > > > | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 | require that values are resolvable to work). .RS .PP Implementations \fIshould not\fR enforce uniqueness and ordering constraints in this method; that is the responsibility of the \fBSet\fR method. .RE .VE TIP516 .\" METHOD: Resolve .TP \fIslot\fR \fBResolve \fIelement\fR .VS This converts an element of the slotted collection into its resolved form; for a simple value, it could just return the value, but for a slot that contains references to commands or classes it should convert those into their fully-qualified forms (so they can be compared with \fBstring equals\fR): that could be done by forwarding to \fBnamespace which\fR or similar. .VE .\" METHOD: Set .TP \fIslot\fR \fBSet \fIelementList\fR . Sets the contents of the slot to the list \fIelementList\fR and returns the empty string. This method must always be called from a stack frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an |
| ︙ | ︙ | |||
615 616 617 618 619 620 621 | earliest location in the slot that it can.) .RE .PP The implementation of these methods is slot-dependent (and responsible for accessing the correct part of the class or object definition). Slots also have an unknown method handler to tie all these pieces together, and they hide their \fBdestroy\fR method so that it is not invoked inadvertently. It is | | | > > > > > > | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 | earliest location in the slot that it can.) .RE .PP The implementation of these methods is slot-dependent (and responsible for accessing the correct part of the class or object definition). Slots also have an unknown method handler to tie all these pieces together, and they hide their \fBdestroy\fR method so that it is not invoked inadvertently. It is \fIrecommended\fR that any user changes to the slot mechanism itself be restricted to defining new operations whose names start with a hyphen. .PP Note that slot instances are not expected to contain the storage for the slot they manage; that will be in or attached to the class or object that they manage. Those instances should provide their own implementations of the \fBGet\fR and \fBSet\fR methods (and optionally \fBResolve\fR; that defaults to a do-nothing pass-through). .PP .VS TIP516 Most slot operations will initially \fBResolve\fR their argument list, combine it with the results of the \fBGet\fR method, and then \fBSet\fR the result. Some operations omit one or both of the first two steps; omitting the third would result in an idempotent read-only operation (but the standard mechanism for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). |
| ︙ | ︙ |
Changes to doc/encoding.n.
1 2 | '\" '\" Copyright (c) 1998 Scriptics Corporation. | < | | | < < < < < | < | < < < | < < < < | < | < < > | < < < < | > > | > > | | > | | > | > > | > > | | < | > > | | > > | < > > | | | | > > | > | | < | | | > > > | | > > > > > > > > > > > > > > | > | < < > > | < > > < > > | | > | < | | | | | | | < > | | < | > > > > | > | | | < > | | | < > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
'\"
'\" Copyright (c) 1998 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH encoding n "8.1" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.SH NAME
encoding \- Manipulate encodings
.SH SYNOPSIS
\fBencoding \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH INTRODUCTION
.PP
Strings in Tcl are logically a sequence of Unicode characters.
These strings are represented in memory as a sequence of bytes that
may be in one of several encodings: modified UTF\-8 (which uses 1 to 4
bytes per character), or a custom encoding start as 8 bit binary data.
.PP
Different operating system interfaces or applications may generate
strings in other encodings such as Shift\-JIS. The \fBencoding\fR
command helps to bridge the gap between Unicode and these other
formats.
.SH DESCRIPTION
.PP
Performs one of several encoding related operations, depending on
\fIoption\fR. The legal \fIoption\fRs are:
.\" METHOD: convertfrom
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR
.VS "TCL8.7 TIP607, TIP656"
.TP
\fBencoding convertfrom\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding data\fR
.VE "TCL8.7 TIP607, TIP656"
.
Converts \fIdata\fR, which should be in binary string encoded as per
\fIencoding\fR, to a Tcl string. If \fIencoding\fR is not specified, the current
system encoding is used.
.PP
.VS "TCL8.7 TIP607, TIP656"
The \fB-profile\fR option determines the command behavior in the presence
of conversion errors. See the \fBPROFILES\fR section below for details. Any premature
termination of processing due to errors is reported through an exception if
the \fB-failindex\fR option is not specified.
.PP
If the \fB-failindex\fR is specified, instead of an exception being raised
on premature termination, the result of the conversion up to the point of the
error is returned as the result of the command. In addition, the index
of the source byte triggering the error is stored in \fBvar\fR. If no
errors are encountered, the entire result of the conversion is returned and
the value \fB-1\fR is stored in \fBvar\fR.
.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: convertto
.TP
\fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR
.TP
\fBencoding convertto\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding data\fR
.
Convert \fIstring\fR to the specified \fIencoding\fR. The result is a Tcl binary
string that contains the sequence of bytes representing the converted string in
the specified encoding. If \fIencoding\fR is not specified, the current system
encoding is used.
.PP
.VS "TCL8.7 TIP607, TIP656"
The \fB-profile\fR and \fB-failindex\fR options have the same effect as
described for the \fBencoding convertfrom\fR command.
.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: dirs
.TP
\fBencoding dirs\fR ?\fIdirectoryList\fR?
.
Tcl can load encoding data files from the file system that describe
additional encodings for it to work with. This command sets the search
path for \fB*.enc\fR encoding data files to the list of directories
\fIdirectoryList\fR. If \fIdirectoryList\fR is omitted then the
command returns the current list of directories that make up the
search path. It is an error for \fIdirectoryList\fR to not be a valid
list. If, when a search for an encoding data file is happening, an
element in \fIdirectoryList\fR does not refer to a readable,
searchable directory, that element is ignored.
.\" METHOD: names
.TP
\fBencoding names\fR
.
Returns a list containing the names of all of the encodings that are
currently available.
The encodings
.QW utf-8
and
.QW iso8859-1
are guaranteed to be present in the list.
.\" METHOD: profiles
.TP
\fBencoding profiles\fR
.VS "TCL8.7 TIP656"
Returns a list of the names of encoding profiles. See \fBPROFILES\fR below.
.VE "TCL8.7 TIP656"
.\" METHOD: system
.TP
\fBencoding system\fR ?\fIencoding\fR?
.
Set the system encoding to \fIencoding\fR. If \fIencoding\fR is
omitted then the command returns the current system encoding. The
system encoding is used whenever Tcl passes strings to system calls.
.\" Do not put .VS on whole section as that messes up the bullet list alignment
.SH PROFILES
.PP
.VS "TCL8.7 TIP656"
Operations involving encoding transforms may encounter several types of
errors such as invalid sequences in the source data, characters that
cannot be encoded in the target encoding and so on.
A \fIprofile\fR prescribes the strategy for dealing with such errors
in one of two ways:
.VE "TCL8.7 TIP656"
.
.IP \(bu
.VS "TCL8.7 TIP656"
Terminating further processing of the source data. The profile does not
determine how this premature termination is conveyed to the caller. By default,
this is signalled by raising an exception. If the \fB-failindex\fR option
is specified, errors are reported through that mechanism.
.VE "TCL8.7 TIP656"
.IP \(bu
.VS "TCL8.7 TIP656"
Continue further processing of the source data using a fallback strategy such
as replacing or discarding the offending bytes in a profile-defined manner.
.VE "TCL8.7 TIP656"
.PP
The following profiles are currently implemented with \fBstrict\fR being
the default if the \fB-profile\fR is not specified.
.VS "TCL8.7 TIP656"
.TP
\fBstrict\fR
.
The \fBstrict\fR profile always stops processing when an conversion error is
encountered. The error is signalled via an exception or the \fB-failindex\fR
option mechanism. The \fBstrict\fR profile implements a Unicode standard
conformant behavior.
.TP
\fBtcl8\fR
.
The \fBtcl8\fR profile always follows the first strategy above and corresponds
to the behavior of encoding transforms in Tcl 8.6. When converting from an
external encoding \fBother than utf-8\fR to Tcl strings with the \fBencoding
convertfrom\fR command, invalid bytes are mapped to their numerically equivalent
code points. For example, the byte 0x80 which is invalid in ASCII would be
mapped to code point U+0080. When converting from \fButf-8\fR, invalid bytes
that are defined in CP1252 are mapped to their Unicode equivalents while those
that are not fall back to the numerical equivalents. For example, byte 0x80 is
defined by CP1252 and is therefore mapped to its Unicode equivalent U+20AC while
byte 0x81 which is not defined by CP1252 is mapped to U+0081. As an additional
special case, the sequence 0xC0 0x80 is mapped to U+0000.
When converting from Tcl strings to an external encoding format using
\fBencoding convertto\fR, characters that cannot be represented in the
target encoding are replaced by an encoding-dependent character, usually
the question mark \fB?\fR.
.TP
\fBreplace\fR
.
Like the \fBtcl8\fR profile, the \fBreplace\fR profile always continues
processing on conversion errors but follows a Unicode standard conformant
method for substitution of invalid source data.
When converting an encoded byte sequence to a Tcl string using
\fBencoding convertfrom\fR, invalid bytes
are replaced by the U+FFFD REPLACEMENT CHARACTER code point.
When encoding a Tcl string with \fBencoding convertto\fR,
code points that cannot be represented in the
target encoding are transformed to an encoding-specific fallback character,
U+FFFD REPLACEMENT CHARACTER for UTF targets and generally `?` for other
encodings.
.VE "TCL8.7 TIP656"
.SH EXAMPLES
.PP
These examples use the utility proc below that prints the Unicode code points
comprising a Tcl string.
.PP
.CS
proc codepoints s {join [lmap c [split $s {}] {
string cat U+ [format %.6X [scan $c %c]]}]
}
.CE
.PP
Example 1: convert a byte sequence in Japanese euc-jp encoding to a TCL string:
.PP
.CS
% codepoints [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"]
U+00306F
.CE
.PP
The result is the unicode codepoint
.QW "\eu306F" ,
which is the Hiragana letter HA.
.VS "TCL8.7 TIP607, TIP656"
.PP
Example 2: Error handling based on profiles:
.PP
The letter \fBA\fR is Unicode character U+0041 and the byte "\ex80" is invalid
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 | % codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80] unexpected byte sequence starting at index 1: '\ex80' .CE .PP Example 3: Get partial data and the error location: .PP .CS | | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 | % codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80] unexpected byte sequence starting at index 1: '\ex80' .CE .PP Example 3: Get partial data and the error location: .PP .CS % codepoints [\fBencoding convertfrom\fR -profile strict -failindex idx ascii AB\ex80] U+000041 U+000042 % set idx 2 .CE .PP Example 4: Encode a character that is not representable in ISO8859-1: .PP .CS % \fBencoding convertto\fR iso8859-1 A\eu0141 A? % \fBencoding convertto\fR -profile strict iso8859-1 A\eu0141 unexpected character at index 1: 'U+000141' % \fBencoding convertto\fR -profile strict -failindex idx iso8859-1 A\eu0141 A % set idx 1 .CE .VE "TCL8.7 TIP607, TIP656" .PP .SH "SEE ALSO" Tcl_GetEncoding(3), fconfigure(n) .SH KEYWORDS encoding, unicode .\" Local Variables: .\" mode: nroff .\" End: |
Changes to doc/eof.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH eof n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end of file condition on channel .SH SYNOPSIS | | < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | < < < < < < < < < < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | .TH eof n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end of file condition on channel .SH SYNOPSIS \fBeof \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBeof\fR command has been superceded by the \fBchan eof\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/exec.n.
| ︙ | ︙ | |||
331 332 333 334 335 336 337 | .PP In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR, the caller must prepend the desired command with .QW "\fBcmd.exe /c\0\fR" because built-in commands are not implemented using executables. .RE .TP | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 | .PP In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR, the caller must prepend the desired command with .QW "\fBcmd.exe /c\0\fR" because built-in commands are not implemented using executables. .RE .TP \fBUnix\fR (including macOS) . The \fBexec\fR command is fully functional and works as described. .SH "UNIX EXAMPLES" .PP Here are some examples of the use of the \fBexec\fR command on Unix. To execute a simple program and get its result: .PP |
| ︙ | ︙ |
Changes to doc/expr.n.
| ︙ | ︙ | |||
329 330 331 332 333 334 335 | tcl::mathfunc::hypot $x $y .CE .PP See the \fBmathfunc\fR(n) documentation for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" .PP | < < < < < < < < | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | tcl::mathfunc::hypot $x $y .CE .PP See the \fBmathfunc\fR(n) documentation for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" .PP Internal floating-point computations are performed using the \fIdouble\fR C type. When converting a string to floating-point value, exponent overflow is detected and results in the \fIdouble\fR value of \fBInf\fR or \fB\-Inf\fR as appropriate. Floating-point overflow and underflow are detected to the degree supported by the hardware, which is generally fairly reliable. |
| ︙ | ︙ |
Changes to doc/fblocked.n.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS | | | < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS \fBfblocked \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBfblocked\fR command has been superceded by the \fBchan blocked\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/fconfigure.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fconfigure \- Set and get options on a channel .SH SYNOPSIS .nf | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fconfigure \- Set and get options on a channel .SH SYNOPSIS .nf \fBfconfigure \fIchannel\fR \fBfconfigure \fIchannel name\fR \fBfconfigure \fIchannel name value \fR?\fIname value ...\fR? .fi .BE .SH DESCRIPTION .PP The \fBfconfigure\fR command has been superceded by the \fBchan configure\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/file.n.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | On Windows, \fB\-archive\fR gives the value or sets or clears the archive attribute of the file. \fB\-hidden\fR gives the value or sets or clears the hidden attribute of the file. \fB\-longname\fR will expand each path element to its long version. This attribute cannot be set. \fB\-readonly\fR gives the value or sets or clears the readonly attribute of the file. \fB\-shortname\fR gives a string where every path element is replaced with its short (8.3) version of the | > > | | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | On Windows, \fB\-archive\fR gives the value or sets or clears the archive attribute of the file. \fB\-hidden\fR gives the value or sets or clears the hidden attribute of the file. \fB\-longname\fR will expand each path element to its long version. This attribute cannot be set. \fB\-readonly\fR gives the value or sets or clears the readonly attribute of the file. \fB\-shortname\fR gives a string where every path element is replaced with its short (8.3) version of the name if possible. For path elements that cannot be mapped to short names, the long name is retained. This attribute cannot be set. \fB\-system\fR gives or sets or clears the value of the system attribute of the file. .PP On macOS and Darwin, \fB\-creator\fR gives or sets the Finder creator type of the file. \fB\-hidden\fR gives or sets or clears the hidden attribute of the file. \fB\-readonly\fR gives or sets or clears the readonly attribute of the file. \fB\-rsrclength\fR gives the length of the resource fork of the file, this attribute can only be set to the value 0, which results in the resource fork being stripped off the file. .PP |
| ︙ | ︙ |
Changes to doc/fileevent.n.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable .SH SYNOPSIS | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < | < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable .SH SYNOPSIS \fBfileevent \fIchannel \fBreadable \fR?\fIscript\fR? .sp \fBfileevent \fIchannel \fBwritable \fR?\fIscript\fR? .BE .SH DESCRIPTION .PP The \fBfileevent\fR command has been superceded by the \fBchan event\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/filename.n.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | .SH "PATH SYNTAX" .PP The rules for native names depend on the value reported in the Tcl \fBplatform\fR element of the \fBtcl_platform\fR array: .TP 10 \fBUnix\fR . | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | .SH "PATH SYNTAX" .PP The rules for native names depend on the value reported in the Tcl \fBplatform\fR element of the \fBtcl_platform\fR array: .TP 10 \fBUnix\fR . On Unix and Apple macOS platforms, Tcl uses path names where the components are separated by slashes. Path names may be relative or absolute, and file names may contain any character other than slash. The file names \fB\&.\fR and \fB\&..\fR are special and refer to the current directory and the parent of the current directory respectively. Multiple adjacent slash characters are interpreted as a single separator, except for the first double slash \fB//\fR in absolute paths. Any number of trailing slash characters at the end of a |
| ︙ | ︙ | |||
151 152 153 154 155 156 157 | \fBtclvars\fR and \fBtm\fR. When any path in an environment variable used to initialize these starts with a tilde, it will be interpreted as if the first element is replaced with the location of the home directory for the given user. If the tilde is followed immediately by a separator, the \fB$HOME\fR environment variable is substituted. Otherwise the characters between the tilde and the next separator are taken as a user name, which is used to retrieve the user's home directory for substitution. This works on | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | \fBtclvars\fR and \fBtm\fR. When any path in an environment variable used to initialize these starts with a tilde, it will be interpreted as if the first element is replaced with the location of the home directory for the given user. If the tilde is followed immediately by a separator, the \fB$HOME\fR environment variable is substituted. Otherwise the characters between the tilde and the next separator are taken as a user name, which is used to retrieve the user's home directory for substitution. This works on POSIX, macOS and Windows platforms. .SH "PORTABILITY ISSUES" .PP Not all file systems are case sensitive, so scripts should avoid code that depends on the case of characters in a file name. In addition, the character sets allowed on different devices may differ, so scripts should choose file names that do not contain special characters like: \fB<>:?"/\e|\fR. |
| ︙ | ︙ |
Changes to doc/flush.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH flush n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel .SH SYNOPSIS | | < < < < < < < < < < < < < < < < < < < | < < < > < < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | .TH flush n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel .SH SYNOPSIS \fBflush \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBflush\fR command has been superceded by the \fBchan flush\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/format.n.
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | printed; if the string is longer than this then the trailing characters will be dropped. If the precision is specified with \fB*\fR rather than a number then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. .SS "OPTIONAL SIZE MODIFIER" .PP The fifth part of a conversion specifier is a size modifier, | | | | > > > | | < < < | 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 | printed; if the string is longer than this then the trailing characters will be dropped. If the precision is specified with \fB*\fR rather than a number then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. .SS "OPTIONAL SIZE MODIFIER" .PP The fifth part of a conversion specifier is a size modifier, which must be \fBll\fR, \fBh\fR, \fBl\fR, \fBz\fR, \fBt\fR, or \fBL\fR. If it is \fBll\fR it specifies that an integer value is taken without truncation for conversion to a formatted substring. If it is \fBh\fR it specifies that an integer value is truncated to a 16-bit range before converting. This option is rarely useful. If it is \fBl\fR (or \fBj\fR or \fBq\fR) it specifies that the integer value is truncated to the same range as that produced by the \fBwide()\fR function of the \fBexpr\fR command (at least a 64-bit range). If it is \fBz\fR or \fBt\fR it specifies that the integer value is truncated to the range determined by the value of the \fBpointerSize\fR element of the \fBtcl_platform\fR array. If it is \fBL\fR it specifies that an integer or double value is taken without truncation for conversion to a formatted substring. If neither of those are present, the integer value is truncated to a 32-bit range. .SS "MANDATORY CONVERSION TYPE" .PP The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: .IP \fBd\fR 10 Convert integer to signed decimal string. |
| ︙ | ︙ |
Changes to doc/fpclassify.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 2018 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" Copyright (c) 2019 Donal Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | '\" '\" Copyright (c) 2018 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" Copyright (c) 2019 Donal Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fpclassify n 9.0 Tcl "Tcl Float Classifier" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fpclassify \- Floating point number classification of Tcl values .SH SYNOPSIS package require \fBtcl 9.0\fR .sp \fBfpclassify \fIvalue\fR .BE .SH DESCRIPTION The \fBfpclassify\fR command takes a floating point number, \fIvalue\fR, and returns one of the following strings that describe it: .IP \fBzero\fR |
| ︙ | ︙ |
Changes to doc/gets.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH gets n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel .SH SYNOPSIS | | | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | .TH gets n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel .SH SYNOPSIS \fBgets \fIchannel\fR ?\fIvarName\fR? .BE .SH DESCRIPTION .PP The \fBgets\fR command has been superceded by the \fBchan gets\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/glob.n.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | or if the target of a link matches the requested type. So, a link to a directory will be returned if \fB\-types d\fR was specified. .RS .PP The second form specifies types where all the types given must match. These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and \fIreadonly\fR, \fIhidden\fR as special permission cases. On the | | | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
or if the target of a link matches the requested type. So, a link to
a directory will be returned if \fB\-types d\fR was specified.
.RS
.PP
The second form specifies types where all the types given must match.
These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and
\fIreadonly\fR, \fIhidden\fR as special permission cases. On the
Macintosh, macOS types and creators are also supported, where any item
which is four characters long is assumed to be a macOS type
(e.g. \fBTEXT\fR). Items which are of the form \fI{macintosh type XXXX}\fR
or \fI{macintosh creator XXXX}\fR will match types or creators
respectively. Unrecognized types, or specifications of multiple macOS
types/creators will signal an error.
.PP
The two forms may be mixed, so \fB\-types {d f r w}\fR will find all
regular files OR directories that have both read AND write permissions.
The following are equivalent:
.PP
.CS
|
| ︙ | ︙ |
Changes to doc/http.n.
| ︙ | ︙ | |||
255 256 257 258 259 260 261 | .\" OPTION: -useragent .TP \fB\-useragent\fI string\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | .\" OPTION: -useragent .TP \fB\-useragent\fI string\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) .QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.10.0 Tcl/9.0.0\fR" . A safe interpreter cannot determine its operating system, and so the default in a safe interpreter is to use a Windows 10 value with the current version numbers of \fBhttp\fR and \fBTcl\fR. .\" OPTION: -zip .TP \fB\-zip\fI boolean\fR . |
| ︙ | ︙ |
Changes to doc/info.n.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | .IP \fBcoroutine\fR \fIcommandName\fR was created by \fBcoroutine\fR. .IP \fBensemble\fR \fIcommandName\fR was created by \fBnamespace ensemble\fR. .IP \fBimport\fR \fIcommandName\fR was created by \fBnamespace import\fR. .IP \fBnative\fR | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | .IP \fBcoroutine\fR \fIcommandName\fR was created by \fBcoroutine\fR. .IP \fBensemble\fR \fIcommandName\fR was created by \fBnamespace ensemble\fR. .IP \fBimport\fR \fIcommandName\fR was created by \fBnamespace import\fR. .IP \fBnative\fR \fIcommandName\fR was created by the \fBTcl_CreateObjCommand\fR interface directly without further registration of the type of command. .IP \fBobject\fR \fIcommandName\fR is the public command that represents an instance of \fBoo::object\fR or one of its subclasses. .IP \fBprivateObject\fR \fIcommandName\fR is the private command, \fBmy\fR by default, that represents an instance of \fBoo::object\fR or one of its subclasses. |
| ︙ | ︙ | |||
198 199 200 201 202 203 204 | relative to the start of the script. .IP \fBfile\fR For type \fBsource\fR, provides the normalized path of the file that contains the command. .IP \fBcmd\fR The command before substitutions were performed. .IP \fBproc\fR | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | relative to the start of the script. .IP \fBfile\fR For type \fBsource\fR, provides the normalized path of the file that contains the command. .IP \fBcmd\fR The command before substitutions were performed. .IP \fBproc\fR For type \fBproc\fR, the name of the procedure containing the command. .IP \fBlambda\fR For a command in a script evaluated as the body of an unnamed routine via the \fBapply\fR command, the definition of that routine. .IP \fBlevel\fR For a frame that corresponds to a level, (to be determined). .PP When a command can be traced to its literal definition in some script, e.g. |
| ︙ | ︙ | |||
278 279 280 281 282 283 284 | .TP \fBinfo library\fR . Returns the value of \fBtcl_library\fR, which is the name of the library directory in which the scripts distributed with Tcl scripts are stored. .\" METHOD: loaded .TP | | | | | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | .TP \fBinfo library\fR . Returns the value of \fBtcl_library\fR, which is the name of the library directory in which the scripts distributed with Tcl scripts are stored. .\" METHOD: loaded .TP \fBinfo loaded \fR?\fIinterp\fR? ?\fIprefix\fR? . Returns the name of each file loaded in \fIinterp\fR by the \fBload\fR command with prefix \fIprefix\fR . If \fIprefix\fR is not given, returns a list where each item is the name of the loaded file and the prefix for which the file was loaded. For a statically-loaded package the name of the file is the empty string. For \fIinterp\fR, the empty string is the current interpreter. .\" METHOD: locals .TP \fBinfo locals \fR?\fIpattern\fR? . If \fIpattern\fR is given, returns the name of each local variable matching |
| ︙ | ︙ | |||
354 355 356 357 358 359 360 | \fIpattern\fR is given, returns only those names that match according to \fBstring match\fR. Only the last component of \fIpattern\fR is a pattern. Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. When \fIpattern\fR is a qualified name, results are fully qualified. .RS .PP | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | \fIpattern\fR is given, returns only those names that match according to \fBstring match\fR. Only the last component of \fIpattern\fR is a pattern. Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. When \fIpattern\fR is a qualified name, results are fully qualified. .RS .PP A variable that has been declared but not yet given a value will be included in the results. .RE .SS "CLASS INTROSPECTION" .PP The following \fIsubcommand\fR values are supported by \fBinfo class\fR: .\" METHOD: call .TP |
| ︙ | ︙ |
Changes to doc/interp.n.
| ︙ | ︙ | |||
388 389 390 391 392 393 394 | application. If your machine has a limit on the size of the C stack, you may get stack overflows before reaching the limit set by the command. If this happens, see if there is a mechanism in your system for increasing the maximum size of the C stack. .RE .\" METHOD: share .TP | | | | | | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 | application. If your machine has a limit on the size of the C stack, you may get stack overflows before reaching the limit set by the command. If this happens, see if there is a mechanism in your system for increasing the maximum size of the C stack. .RE .\" METHOD: share .TP \fBinterp share\fI srcPath channel destPath\fR . Causes the IO channel identified by \fIchannel\fR to become shared between the interpreter identified by \fIsrcPath\fR and the interpreter identified by \fIdestPath\fR. Both interpreters have the same permissions on the IO channel. Both interpreters must close it to close the underlying IO channel; IO channels accessible in an interpreter are automatically closed when an interpreter is destroyed. .\" METHOD: target .TP \fBinterp target\fI path alias\fR . Returns a Tcl list describing the target interpreter for an alias. The alias is specified with an interpreter path and source command name, just as in \fBinterp alias\fR above. The name of the target interpreter is returned as an interpreter path, relative to the invoking interpreter. If the target interpreter for the alias is the invoking interpreter then an empty list is returned. If the target interpreter for the alias is not the invoking interpreter or one of its descendants then an error is generated. The target command does not have to be defined at the time of this invocation. .\" METHOD: transfer .TP \fBinterp transfer\fI srcPath channel destPath\fR . Causes the IO channel identified by \fIchannel\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the interpreter identified by \fIsrcPath\fR. .SH "CHILD COMMAND" .PP For each child interpreter created with the \fBinterp\fR command, a new Tcl command is created in the parent interpreter with the same name as the new interpreter. This command may be used to invoke |
| ︙ | ︙ | |||
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | \fBlsort\fR \fBnamespace\fR \fBpackage\fR \fBpid\fR \fBproc\fR \fBputs\fR \fBread\fR \fBregexp\fR \fBregsub\fR \fBrename\fR \fBreturn\fR \fBscan\fR \fBseek\fR \fBset\fR \fBsplit\fR \fBstring\fR \fBsubst\fR \fBswitch\fR \fBtell\fR \fBtime\fR \fBtrace\fR \fBunset\fR \fBupdate\fR \fBuplevel\fR \fBupvar\fR \fBvariable\fR \fBvwait\fR \fBwhile\fR .DE The following commands are hidden by \fBinterp create\fR when it creates a safe interpreter: .DS .ta 1.2i 2.4i 3.6i \fBcd\fR \fBencoding\fR \fBexec\fR \fBexit\fR \fBfconfigure\fR \fBfile\fR \fBglob\fR \fBload\fR \fBopen\fR \fBpwd\fR \fBsocket\fR \fBsource\fR | > | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 | \fBlsort\fR \fBnamespace\fR \fBpackage\fR \fBpid\fR \fBproc\fR \fBputs\fR \fBread\fR \fBregexp\fR \fBregsub\fR \fBrename\fR \fBreturn\fR \fBscan\fR \fBseek\fR \fBset\fR \fBsplit\fR \fBstring\fR \fBsubst\fR \fBswitch\fR \fBtell\fR \fBtime\fR \fBtrace\fR \fBunset\fR \fBupdate\fR \fBuplevel\fR \fBupvar\fR \fBvariable\fR \fBvwait\fR \fBwhile\fR \fBzlib\fR .DE The following commands are hidden by \fBinterp create\fR when it creates a safe interpreter: .DS .ta 1.2i 2.4i 3.6i \fBcd\fR \fBencoding\fR \fBexec\fR \fBexit\fR \fBfconfigure\fR \fBfile\fR \fBglob\fR \fBload\fR \fBopen\fR \fBpwd\fR \fBsocket\fR \fBsource\fR \fBunload\fR \fBzipfs\fR .DE These commands can be recreated later as Tcl procedures or aliases, or re-exposed by \fBinterp expose\fR. .PP The following commands from Tcl's library of support procedures are not present in a safe interpreter: .DS |
| ︙ | ︙ |
Changes to doc/ledit.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2022 Ashok P. Nadkarni <apnmbx-public@yahoo.com>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2022 Ashok P. Nadkarni <apnmbx-public@yahoo.com>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH ledit n 9.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME ledit \- Replace elements of a list stored in variable .SH SYNOPSIS \fBledit \fIlistVar first last \fR?\fIvalue value ...\fR? |
| ︙ | ︙ |
Changes to doc/library.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1991-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH library n "8.0" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1991-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH library n "8.0" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, writeFile \- standard library of Tcl procedures .SH SYNOPSIS .nf \fBauto_execok \fIcmd\fR \fBauto_import \fIpattern\fR \fBauto_load \fIcmd\fR \fBauto_mkindex \fIdir pattern pattern ...\fR \fBauto_qualify \fIcommand namespace\fR |
| ︙ | ︙ |
Changes to doc/load.n.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | by calling the \fBTcl_StaticLibrary\fR procedure. If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. .PP If \fIprefix\fR is omitted or specified as an empty string, Tcl tries to guess the prefix by taking the last element of \fIfileName\fR, strip off the first three characters if they | | | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
by calling the \fBTcl_StaticLibrary\fR procedure.
If \fIfileName\fR is an empty string, then \fIprefix\fR must
be specified.
.PP
If \fIprefix\fR is omitted or specified as an empty string,
Tcl tries to guess the prefix by taking the last element of
\fIfileName\fR, strip off the first three characters if they
are \fBlib\fR, then strip off the next four characters if
they are \fBtcl9\fR, and use any following wordchars
but not digits, converted to titlecase as the prefix.
For example, the command \fBload libxyz4.2.so\fR uses the prefix
\fBXyz\fR and the command \fBload bin/last.so {}\fR uses the
prefix \fBLast\fR.
.PP
If \fIfileName\fR is an empty string, then \fIprefix\fR must
be specified.
The \fBload\fR command first searches for a statically loaded library
|
| ︙ | ︙ |
Changes to doc/lpop.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2018 Peter Spjuth. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2018 Peter Spjuth. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lpop n 9.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lpop \- Get and remove an element in a list .SH SYNOPSIS \fBlpop \fIvarName ?index ...?\fR |
| ︙ | ︙ |
Changes to doc/lremove.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2019 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2019 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lremove n 9.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lremove \- Remove elements from a list by index .SH SYNOPSIS \fBlremove \fIlist\fR ?\fIindex ...\fR? |
| ︙ | ︙ |
Changes to doc/lsearch.n.
| ︙ | ︙ | |||
233 234 235 236 237 238 239 |
\fBlsearch\fR -start 3 {a b c a b c} c
\fI\(-> 5\fR
.CE
.PP
It is also possible to search inside elements:
.PP
.CS
| | | | | | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
\fBlsearch\fR -start 3 {a b c a b c} c
\fI\(-> 5\fR
.CE
.PP
It is also possible to search inside elements:
.PP
.CS
\fBlsearch\fR -index 1 -all -inline {{abc abc} {abc bcd} {abc cde}} *bc*
\fI\(-> {abc abc} {abc bcd}\fR
.CE
.PP
The same thing for a flattened list:
.PP
.CS
\fBlsearch\fR -stride 2 -index 1 -all -inline {abc abc abc bcd abc cde} *bc*
\fI\(-> abc abc abc bcd\fR
.CE
.SH "SEE ALSO"
foreach(n),
list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lseq(n), lset(n), lsort(n),
string(n)
|
| ︙ | ︙ |
Changes to doc/lseq.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2022 Eric Taylor. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2022 Eric Taylor. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lseq n 9.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lseq \- Build a numeric sequence returned as a list .SH SYNOPSIS .nf |
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | elements, and if \fIcount\fR is not supplied, it is computed as: .RS .PP .CS \fIcount\fR = int( (\fIend\fR - \fIstart\fR + \fIstep\fR) / \fIstep\fR ) .CE .RE | < < < < < < | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | elements, and if \fIcount\fR is not supplied, it is computed as: .RS .PP .CS \fIcount\fR = int( (\fIend\fR - \fIstart\fR + \fIstep\fR) / \fIstep\fR ) .CE .RE .SH EXAMPLES .CS .\" \fBlseq\fR 3 \fI\(-> 0 1 2\fR \fBlseq\fR 3 0 |
| ︙ | ︙ |
Changes to doc/msgcat.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS .nf | | | | 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 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS .nf \fBpackage require tcl 9.0\fR \fBpackage require msgcat 1.7\fR \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .VS "TIP 412" \fB::msgcat::mcexists\fR ?\fB\-exactnamespace\fR? ?\fB\-exactlocale\fR? \fIsrc-string\fR .VE "TIP 412" .VS "TIP 490" \fB::msgcat::mcpackagenamespaceget\fR .VE "TIP 490" \fB::msgcat::mclocale \fR?\fInewLocale\fR? .VS "TIP 499" \fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... .VE "TIP 499" .VS "TIP 412" \fB::msgcat::mcloadedlocales subcommand\fR .VE "TIP 412" \fB::msgcat::mcload \fIdirname\fR \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? \fB::msgcat::mcmset \fIlocale src-trans-list\fR \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? \fB::msgcat::mcflmset \fIsrc-trans-list\fR \fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR? |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 | \fB::msgcat::mc\fR is the main function used to localize an application. Instead of using an English string directly, an application can pass the English string through \fB::msgcat::mc\fR and use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | \fB::msgcat::mc\fR is the main function used to localize an application. Instead of using an English string directly, an application can pass the English string through \fB::msgcat::mc\fR and use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE .\" COMMAND: mcn .TP \fB::msgcat::mcn \fInamespace src-string\fR ?\fIarg arg ...\fR? .VS "TIP 490" Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. .PP .RS |
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
.CS
::msgcat::mcpreferences fr en {}
.CE
.RE
.PP
.\" COMMAND: mcloadedlocales
.TP
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
.CS
::msgcat::mcpreferences fr en {}
.CE
.RE
.PP
.\" COMMAND: mcloadedlocales
.TP
\fB::msgcat::mcloadedlocales subcommand\fR
.VS "TIP 499"
This group of commands manage the list of loaded locales for packages not
setting a package locale.
.PP
.RS
The subcommand \fBloaded\fR returns the list of currently loaded locales.
.PP
|
| ︙ | ︙ | |||
378 379 380 381 382 383 384 | .PP .CS language[_country][_modifier] .CE .PP On Windows and Cygwin, if none of those environment variables is set, msgcat will attempt to extract locale information from the registry. | | | < | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 | .PP .CS language[_country][_modifier] .CE .PP On Windows and Cygwin, if none of those environment variables is set, msgcat will attempt to extract locale information from the registry. The RFC4747 locale name "lang-script-country-options" is transformed to the locale as "lang_country_script" (Example: sr-Latn-CS -> sr_cs_latin). If all these attempts to discover an initial locale from the user's environment fail, msgcat defaults to an initial locale of .QW C . .PP When a locale is specified by the user, a .QW "best match" search is performed during string translation. For example, if a user |
| ︙ | ︙ | |||
594 595 596 597 598 599 600 | .PP .RS .VS "TIP 499" If a set of locale preferences is given, it is set as package locale preference list. The package locale is set to the first element of the preference list. A package locale is activated, if it was not set so far. .PP | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 | .PP .RS .VS "TIP 499" If a set of locale preferences is given, it is set as package locale preference list. The package locale is set to the first element of the preference list. A package locale is activated, if it was not set so far. .PP Locale preferences are loaded now for the package, if not yet loaded. .VE "TIP 499" .RE .PP .\" METHOD: loaded .TP \fB::msgcat::mcpackagelocale loaded\fR . |
| ︙ | ︙ |
Changes to doc/namespace.n.
| ︙ | ︙ | |||
491 492 493 494 495 496 497 | If you provide a fully-qualified name that starts with a \fB::\fR, there is no question about what command, variable, or namespace you mean. However, if the name does not start with a \fB::\fR (i.e., is \fIrelative\fR), Tcl follows basic rules for looking it up: .IP \(bu | | | > > | < | | < < | | | | | | | | | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
If you provide a fully-qualified name that starts with a \fB::\fR,
there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR),
Tcl follows basic rules for looking it up:
.IP \(bu
\fBVariable names\fR are always resolved starting in the current
namespace. In the absence of special resolvers, foo::bar::baz refers to
a variable named "baz" in a namespace named "bar" that is a child of a
namespace named "foo" that is a child of the current namespace of the interpreter.
.IP \(bu
\fBCommand names\fR are always resolved by looking in the current namespace
first. If not found there, they are searched for in every namespace on the
current namespace's command path (which is empty by default). If not found
there, command names are looked up in the global namespace (or, failing that,
are processed by the appropriate \fBnamespace unknown\fR handler.)
.IP \(bu
\fBNamespace names\fR are always resolved by looking in only the current
namespace.
.PP
In the following example,
.PP
.CS
set traceLevel 0
\fBnamespace eval\fR Debug {
printTrace $traceLevel
}
.CE
.PP
Tcl looks for \fBtraceLevel\fR in the namespace \fBDebug\fR.
It looks up the command \fBprintTrace\fR in the same way.
If a variable or command name is not found,
the name is undefined.
To make this point absolutely clear, consider the following example:
.PP
.CS
set traceLevel 0
\fBnamespace eval\fR Foo {
variable traceLevel 3
\fBnamespace eval\fR Debug {
printTrace $traceLevel
}
}
.CE
.PP
Here Tcl looks for \fBtraceLevel\fR in the namespace \fBFoo::Debug\fR.
The variables \fBFoo::traceLevel\fR and \fBFoo::Debug::traceLevel\fR
are completely ignored during the name resolution process.
.PP
You can use the \fBnamespace which\fR command to clear up any question
about name resolution.
For example, the command:
.PP
.CS
\fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR -variable traceLevel}
.CE
.PP
returns the empty string.
The command,
.PP
.CS
\fBnamespace eval\fR Foo {\fBnamespace which\fR -variable traceLevel}
.CE
.PP
returns the empty string as well.
.PP
As mentioned above,
namespace names and variables are looked up differently
than the names of commands.
Namespace names and variables are always resolved in the current namespace.
This means, for example,
that a \fBnamespace eval\fR command that creates a new namespace
always creates a child of the current namespace
unless the new namespace name begins with \fB::\fR.
.PP
Tcl has no access control to limit what variables, commands,
or namespaces you can reference.
|
| ︙ | ︙ |
Changes to doc/object.n.
| ︙ | ︙ | |||
62 63 64 65 66 67 68 69 70 71 72 73 74 75 | .\" METHOD: eval .TP \fIobj \fBeval\fR ?\fIarg ...\fR? . This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR, and then evaluates the resulting script in the namespace that is uniquely associated with \fIobj\fR, returning the result of the evaluation. .\" METHOD: unknown .TP \fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR? . This method is called when an attempt to invoke the method \fImethodName\fR on object \fIobj\fR fails. The arguments that the user supplied to the method are given as \fIarg\fR arguments. | > > > > > | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | .\" METHOD: eval .TP \fIobj \fBeval\fR ?\fIarg ...\fR? . This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR, and then evaluates the resulting script in the namespace that is uniquely associated with \fIobj\fR, returning the result of the evaluation. .RS .PP Note that object-internal commands such as \fBmy\fR and \fBself\fR can be invoked in this context. .RE .\" METHOD: unknown .TP \fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR? . This method is called when an attempt to invoke the method \fImethodName\fR on object \fIobj\fR fails. The arguments that the user supplied to the method are given as \fIarg\fR arguments. |
| ︙ | ︙ |
Changes to doc/prefix.n.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | .TP \fB::tcl::prefix longest\fI table string\fR . Returns the longest common prefix of all elements in \fItable\fR that begin with the prefix \fIstring\fR. .\" METHOD: match .TP | | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | .TP \fB::tcl::prefix longest\fI table string\fR . Returns the longest common prefix of all elements in \fItable\fR that begin with the prefix \fIstring\fR. .\" METHOD: match .TP \fB::tcl::prefix match\fR ?\fIoption ...\fR? \fItable string\fR . If \fIstring\fR equals one element in \fItable\fR or is a prefix to exactly one element, the matched element is returned. If not, the result depends on the \fB\-error\fR option. (It is recommended that the \fItable\fR be sorted before use with this subcommand, so that the list of matches presented in the error message also becomes sorted, though this is not strictly necessary for the operation of this subcommand itself.) The following options are supported: .RS .\" OPTION: -exact .TP \fB\-exact\fR . Accept only exact matches. .\" OPTION: -message |
| ︙ | ︙ |
Changes to doc/process.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2017 Frederic Bonnet. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2017 Frederic Bonnet. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH process n 9.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::process \- Subprocess management .SH SYNOPSIS \fB::tcl::process \fIoption \fR?\fIarg arg ...\fR? |
| ︙ | ︙ |
Changes to doc/puts.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH puts n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel .SH SYNOPSIS | | < < < < < < < < < < < < < < | < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | .TH puts n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel .SH SYNOPSIS \fBputs \fR?\fB\-nonewline\fR? ?\fIchannel\fR? \fIstring\fR .BE .SH DESCRIPTION .PP The \fBputs\fR command has been superceded by the \fBchan puts\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/re_syntax.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions .BE .SH DESCRIPTION .PP |
| ︙ | ︙ |
Changes to doc/read.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH read n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel .SH SYNOPSIS | | | | < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .TH read n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel .SH SYNOPSIS \fBread \fR?\fB\-nonewline\fR? \fIchannel\fR .sp \fBread \fIchannel numChars\fR .BE .SH DESCRIPTION .PP The \fBread\fR command has been superceded by the \fBchan read\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/refchan.n.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | .\" Note: do not modify the .SH NAME line immediately below! .SH NAME refchan \- command handler API of reflected channels .SH SYNOPSIS .nf \fBchan create \fImode cmdPrefix\fR | | | | | | | | | | | | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | .\" Note: do not modify the .SH NAME line immediately below! .SH NAME refchan \- command handler API of reflected channels .SH SYNOPSIS .nf \fBchan create \fImode cmdPrefix\fR \fIcmdPrefix \fBblocking\fI channel mode\fR \fIcmdPrefix \fBcget\fI channel option\fR \fIcmdPrefix \fBcgetall\fI channel\fR \fIcmdPrefix \fBconfigure\fI channel option value\fR \fIcmdPrefix \fBfinalize\fI channel\fR \fIcmdPrefix \fBinitialize\fI channel mode\fR \fIcmdPrefix \fBread\fI channel count\fR \fIcmdPrefix \fBseek\fI channel offset base\fR \fIcmdPrefix \fBwatch\fI channel eventspec\fR \fIcmdPrefix \fBwrite\fI channel data\fR .fi .BE .SH DESCRIPTION .PP The Tcl-level handler for a reflected channel has to be a command with subcommands (termed an \fIensemble\fR, as it is a command such as that created by \fBnamespace ensemble\fR \fBcreate\fR, though the implementation of handlers for reflected channel \fIis not\fR tied to \fBnamespace ensemble\fRs in any way; see \fBEXAMPLE\fR below for how to build an \fBoo::class\fR that supports the API). Note that \fIcmdPrefix\fR is whatever was specified in the call to \fBchan create\fR, and may consist of multiple arguments; this will be expanded to multiple words in place of the prefix. .PP Of all the possible subcommands, the handler \fImust\fR support \fBinitialize\fR, \fBfinalize\fR, and \fBwatch\fR. Support for the other subcommands is optional. .SS "MANDATORY SUBCOMMANDS" .\" METHOD: initialize .TP \fIcmdPrefix \fBinitialize \fIchannel mode\fR . An invocation of this subcommand will be the first call the \fIcmdPrefix\fR will receive for the specified new \fIchannel\fR. It is the responsibility of this subcommand to set up any internal data structures required to keep track of the channel and its state. .RS .PP The return value of the method has to be a list containing the names of all subcommands supported by the \fIcmdPrefix\fR. This also tells the Tcl core which version of the API for reflected channels is used by |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | will usually contain at least one element. .PP The subcommand must throw an error if the chosen mode is not supported by the \fIcmdPrefix\fR. .RE .\" METHOD: finalize .TP | | | | | | | | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | will usually contain at least one element. .PP The subcommand must throw an error if the chosen mode is not supported by the \fIcmdPrefix\fR. .RE .\" METHOD: finalize .TP \fIcmdPrefix \fBfinalize \fIchannel\fR . An invocation of this subcommand will be the last call the \fIcmdPrefix\fR will receive for the specified \fIchannel\fR. It will be generated just before the destruction of the data structures of the channel held by the Tcl core. The command handler \fImust not\fR access the \fIchannel\fR anymore in no way. Upon this subcommand being called, any internal resources allocated to this channel must be cleaned up. .RS .PP The return value of this subcommand is ignored. .PP If the subcommand throws an error the command which caused its invocation (usually \fBchan close\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as (and converted to) an error. .PP This subcommand is not invoked if the creation of the channel was aborted during \fBinitialize\fR (See above). .RE .\" METHOD: watch .TP \fIcmdPrefix \fBwatch \fIchannel eventspec\fR . This subcommand notifies the \fIcmdPrefix\fR that the specified \fIchannel\fR is interested in the events listed in the \fIeventspec\fR. This argument is a list containing any of \fBread\fR and \fBwrite\fR. The list may be empty, which signals that the channel does not wish to be notified of any events. In that situation, the handler should disable event generation completely. .RS .PP \fBWarning:\fR Any return value of the subcommand is ignored. This includes all errors thrown by the subcommand, \fBbreak\fR, \fBcontinue\fR, and custom return codes. .PP This subcommand interacts with \fBchan postevent\fR. Trying to post an event which was not listed in the last call to \fBwatch\fR will cause \fBchan postevent\fR to throw an error. .RE .SS "OPTIONAL SUBCOMMANDS" .\" METHOD: read .TP \fIcmdPrefix \fBread \fIchannel count\fR . This \fIoptional\fR subcommand is called when the user requests data from the channel \fIchannel\fR. \fIcount\fR specifies how many \fIbytes\fR have been requested. If the subcommand is not supported then it is not possible to read from the channel handled by the command. .RS .PP The return value of this subcommand is taken as the requested data \fIbytes\fR. If the returned data contains more bytes than requested, an error will be signaled and later thrown by the command which |
| ︙ | ︙ | |||
172 173 174 175 176 177 178 | If the subcommand throws any other error, the command which caused its invocation (usually \fBgets\fR, or \fBread\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: write .TP | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | If the subcommand throws any other error, the command which caused its invocation (usually \fBgets\fR, or \fBread\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: write .TP \fIcmdPrefix \fBwrite \fIchannel data\fR . This \fIoptional\fR subcommand is called when the user writes data to the channel \fIchannel\fR. The \fIdata\fR argument contains \fIbytes\fR, not characters. Any type of transformation (EOL, encoding) configured for the channel has already been applied at this point. If this subcommand is not supported then it is not possible to write to the channel handled by the command. .RS .PP The return value of the subcommand is taken as the number of bytes |
| ︙ | ︙ | |||
230 231 232 233 234 235 236 | If the subcommand throws any other error the command which caused its invocation (usually \fBputs\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: seek .TP | | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | If the subcommand throws any other error the command which caused its invocation (usually \fBputs\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: seek .TP \fIcmdPrefix \fBseek \fIchannel offset base\fR . This \fIoptional\fR subcommand is responsible for the handling of \fBchan seek\fR and \fBchan tell\fR requests on the channel \fIchannel\fR. If it is not supported then seeking will not be possible for the channel. .RS .PP The \fIbase\fR argument is the same as the equivalent argument of the builtin \fBchan seek\fR, namely: .IP \fBstart\fR 10 Seeking is relative to the beginning of the channel. |
| ︙ | ︙ | |||
267 268 269 270 271 272 273 | .PP The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR request, i.e.,\ seek nothing relative to the current location, making the new location identical to the current one, which is then returned. .RE .\" METHOD: configure .TP | | | | | | | | | | | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | .PP The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR request, i.e.,\ seek nothing relative to the current location, making the new location identical to the current one, which is then returned. .RE .\" METHOD: configure .TP \fIcmdPrefix \fBconfigure \fIchannel option value\fR . This \fIoptional\fR subcommand is for setting the type-specific options of channel \fIchannel\fR. The \fIoption\fR argument indicates the option to be written, and the \fIvalue\fR argument indicates the value to set the option to. .RS .PP This subcommand will never try to update more than one option at a time; that is behavior implemented in the Tcl channel core. .PP The return value of the subcommand is ignored. .PP If the subcommand throws an error the command which performed the (re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: cget .TP \fIcmdPrefix \fBcget \fIchannel option\fR . This \fIoptional\fR subcommand is used when reading a single type-specific option of channel \fIchannel\fR. If this subcommand is supported then the subcommand \fBcgetall\fR must be supported as well. .RS .PP The subcommand should return the value of the specified \fIoption\fR. .PP If the subcommand throws an error, the command which performed the (re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fIerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: cgetall .TP \fIcmdPrefix \fBcgetall \fIchannel\fR . This \fIoptional\fR subcommand is used for reading all type-specific options of channel \fIchannel\fR. If this subcommand is supported then the subcommand \fBcget\fR has to be supported as well. .RS .PP The subcommand should return a list of all options and their values. This list must have an even number of elements. .PP If the subcommand throws an error the command which performed the (re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: blocking .TP \fIcmdPrefix \fBblocking \fIchannel mode\fR . This \fIoptional\fR subcommand handles changes to the blocking mode of the channel \fIchannel\fR. The \fImode\fR is a boolean flag. A true value means that the channel has to be set to blocking, and a false value means that the channel should be non-blocking. .RS .PP The return value of the subcommand is ignored. .PP If the subcommand throws an error the command which caused its invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: truncate .TP \fIcmdPrefix \fBtruncate\fI channel length\fR . This \fIoptional\fR subcommand handles changing the length of the underlying data stream for the channel \fIchannel\fR. Its length gets set to \fIlength\fR. .RS .PP If the subcommand throws an error the command which caused its invocation (usually \fBchan truncate\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. |
| ︙ | ︙ |
Changes to doc/return.n.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | The return code of the procedure is 4 (\fBTCL_CONTINUE\fR). The procedure command behaves in its calling context as if it were the command \fBcontinue\fR. .TP 13 \fIvalue\fR . \fIValue\fR must be an integer; it will be returned as the | | > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | The return code of the procedure is 4 (\fBTCL_CONTINUE\fR). The procedure command behaves in its calling context as if it were the command \fBcontinue\fR. .TP 13 \fIvalue\fR . \fIValue\fR must be an integer; it will be returned as the return code for the current procedure. Applications and packages should use values in the range 5 to 1073741823 (0x3fffffff) for their own purposes. Values outside this range are reserved for use by Tcl. .LP When a procedure wants to signal that it has received invalid arguments from its caller, it may use \fBreturn -code error\fR with \fIresult\fR set to a suitable error message. Otherwise usage of the \fBreturn -code\fR option is mostly limited to procedures that implement a new control structure. .PP |
| ︙ | ︙ |
Changes to doc/safe.n.
| ︙ | ︙ | |||
303 304 305 306 307 308 309 | Additionally, the shared object file must contain a safe entry point; see the manual page for the \fBload\fR command for more details. .TP \fBfile\fR ?\fIsubcommand args...\fR? . The \fBfile\fR alias provides access to a safe subset of the subcommands of the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR, | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 | Additionally, the shared object file must contain a safe entry point; see the manual page for the \fBload\fR command for more details. .TP \fBfile\fR ?\fIsubcommand args...\fR? . The \fBfile\fR alias provides access to a safe subset of the subcommands of the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR, \fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathtype\fR and \fBsplit\fR subcommands. For more details on what these subcommands do see the manual page for the \fBfile\fR command. .TP \fBencoding\fR ?\fIsubcommand args...\fR? . The \fBencoding\fR alias provides access to a safe subset of the subcommands of the \fBencoding\fR command; it disallows setting of |
| ︙ | ︙ | |||
439 440 441 442 443 444 445 | .PP With "Sync Mode" on, the option \fB\-autoPath\fR is undefined, and the Safe Base sets the child's ::auto_path to a tokenized form of the access path. In addition to the directories present if "Safe Mode" is off, the ::auto_path includes the numerous subdirectories and module paths that belong to the access path. .SH SYNC MODE | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 | .PP With "Sync Mode" on, the option \fB\-autoPath\fR is undefined, and the Safe Base sets the child's ::auto_path to a tokenized form of the access path. In addition to the directories present if "Safe Mode" is off, the ::auto_path includes the numerous subdirectories and module paths that belong to the access path. .SH SYNC MODE Before Tcl version 9.0, the Safe Base kept each safe interpreter's ::auto_path synchronized with a tokenized form of its access path. Limitations of Tcl 8.4 and earlier made this feature necessary. This definition of ::auto_path did not conform its specification in library(n) and pkg_mkIndex(n), but nevertheless worked perfectly well for the discovery and loading of packages. The introduction of Tcl modules in Tcl 8.5 added a large number of directories to the access path, and it is inconvenient to have these additional directories unnecessarily appended to the ::auto_path. |
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
Example of use with "Sync Mode" off: when initializing a safe interpreter
with a non-empty access path, the ::auto_path will be set to {} unless its
own value is also specified:
.RS
.PP
.CS
safe::interpCreate foo -accessPath {
| | | | | | | | | | | | | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
Example of use with "Sync Mode" off: when initializing a safe interpreter
with a non-empty access path, the ::auto_path will be set to {} unless its
own value is also specified:
.RS
.PP
.CS
safe::interpCreate foo -accessPath {
/usr/local/TclHome/lib/tcl9.0
/usr/local/TclHome/lib/tcl9.0/http1.0
/usr/local/TclHome/lib/tcl9.0/opt0.4
/usr/local/TclHome/lib/tcl9.0/msgs
/usr/local/TclHome/lib/tcl9.0/encoding
/usr/local/TclHome/lib
}
# The child's ::auto_path must be given a suitable value:
safe::interpConfigure foo -autoPath {
/usr/local/TclHome/lib/tcl9.0
/usr/local/TclHome/lib
}
# The two commands can be combined:
safe::interpCreate foo -accessPath {
/usr/local/TclHome/lib/tcl9.0
/usr/local/TclHome/lib/tcl9.0/http1.0
/usr/local/TclHome/lib/tcl9.0/opt0.4
/usr/local/TclHome/lib/tcl9.0/msgs
/usr/local/TclHome/lib/tcl9.0/encoding
/usr/local/TclHome/lib
} -autoPath {
/usr/local/TclHome/lib/tcl9.0
/usr/local/TclHome/lib
}
.CE
.RE
.PP
Example of use with "Sync Mode" off: the command
\fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's
|
| ︙ | ︙ |
Changes to doc/scan.n.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | at most once and the empty positions will be filled in with empty strings. .SS "OPTIONAL SIZE MODIFIER" .PP The size modifier field is used only when scanning a substring into one of Tcl's integer values. The size modifier field dictates the integer range acceptable to be stored in a variable, or, for the inline case, in a position in the result list. | | > | | | < | | > | | | > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | at most once and the empty positions will be filled in with empty strings. .SS "OPTIONAL SIZE MODIFIER" .PP The size modifier field is used only when scanning a substring into one of Tcl's integer values. The size modifier field dictates the integer range acceptable to be stored in a variable, or, for the inline case, in a position in the result list. The syntactically valid values for the size modifier are \fBh\fR, \fBl\fR, \fBz\fR, \fBt\fR, \fBq\fR, \fBj\fR, \fBll\fR, and \fBL\fR. The \fBh\fR size modifier value is equivalent to the absence of a size modifier in the the conversion specifier. Either one indicates the integer range to be stored is limited to the 32-bit range. The \fBL\fR size modifier is equivalent to the \fBll\fR size modifier. Either one indicates the integer range to be stored is unlimited. The \fBl\fR (or \fBq\fR or \fBj\fR) size modifier indicates that the integer range to be stored is limited to the same range produced by the \fBwide()\fR function of the \fBexpr\fR command. The \fBz\fR and \fBt\fR modifiers indicate the integer range to be the same as for either \fBh\fR or \fBl\fR, depending on the value of the \fBpointerSize\fR element of the \fBtcl_platform\fR array. .SS "MANDATORY CONVERSION CHARACTER" .PP The following conversion characters are supported: .IP \fBd\fR The input substring must be a decimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. |
| ︙ | ︙ | |||
103 104 105 106 107 108 109 | It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. .IP \fBu\fR The input substring must be a decimal integer. The integer value is truncated as required by the size modifier value, and the corresponding unsigned value for that truncated range is computed and stored in the variable as a decimal string. | < < < | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. .IP \fBu\fR The input substring must be a decimal integer. The integer value is truncated as required by the size modifier value, and the corresponding unsigned value for that truncated range is computed and stored in the variable as a decimal string. .IP \fBi\fR The input substring must be an integer. The base (i.e. decimal, octal, or hexadecimal) is determined by the C convention (leading 0 for octal; prefix 0x for hexadecimal). The integer value is stored in the variable, truncated as required by the size modifier value. .IP \fBc\fR |
| ︙ | ︙ | |||
246 247 248 249 250 251 252 | puts "X=$x, Y=$y" .CE .PP An interactive session demonstrating the truncation of integer values determined by size modifiers: .PP .CS | < < | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | puts "X=$x, Y=$y" .CE .PP An interactive session demonstrating the truncation of integer values determined by size modifiers: .PP .CS \fI%\fR scan 20000000000000000000 %d 2147483647 \fI%\fR scan 20000000000000000000 %ld 9223372036854775807 \fI%\fR scan 20000000000000000000 %lld 20000000000000000000 .CE |
| ︙ | ︙ |
Changes to doc/seek.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH seek n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel .SH SYNOPSIS | | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | .TH seek n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel .SH SYNOPSIS \fBseek \fIchannel offset \fR?\fIorigin\fR? .BE .SH DESCRIPTION .PP The \fBseek\fR command has been superceded by the \fBchan seek\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/socket.n.
| ︙ | ︙ | |||
257 258 259 260 261 262 263 | set sockChan [\fBsocket\fR $server 9900] gets $sockChan line1 gets $sockChan line2 close $sockChan puts "The time on $server is $line1" puts "That is [lindex $line2 0]s since the server started" .CE | < < | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 | set sockChan [\fBsocket\fR $server 9900] gets $sockChan line1 gets $sockChan line2 close $sockChan puts "The time on $server is $line1" puts "That is [lindex $line2 0]s since the server started" .CE .SH "SEE ALSO" chan(n), flush(n), open(n), read(n) .SH KEYWORDS asynchronous I/O, bind, channel, connection, domain name, host, network address, socket, tcp '\" Local Variables: '\" mode: nroff |
| ︙ | ︙ |
Changes to doc/string.n.
| ︙ | ︙ | |||
146 147 148 149 150 151 152 | .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR. .IP \fBentier\fR 12 . | | < < | | | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR. .IP \fBentier\fR 12 . Synonym for \fBinteger\fR. .IP \fBfalse\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false. .IP \fBgraph\fR 12 Any Unicode printing character, except space. .IP \fBinteger\fR 12 Any of the valid string formats for an integer value of arbitrary size in Tcl, with optional surrounding whitespace. The formats accepted are exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR. .IP \fBlist\fR 12 Any proper list structure, with optional surrounding whitespace. In case of improper list structure, 0 is returned and the \fIvarname\fR will contain the index of the .QW element where the list parsing fails, or \-1 if this cannot be determined. .IP \fBlower\fR 12 |
| ︙ | ︙ |
Changes to doc/tclsh.1.
| ︙ | ︙ | |||
152 153 154 155 156 157 158 | The variable \fBtcl_prompt2\fR is used in a similar way when a newline is typed but the current command is not yet complete; if \fBtcl_prompt2\fR is not set then no prompt is output for incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. | | | | > > > > | | | | | > > > > > > > > | | | 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 | The variable \fBtcl_prompt2\fR is used in a similar way when a newline is typed but the current command is not yet complete; if \fBtcl_prompt2\fR is not set then no prompt is output for incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "ZIPFS VIRTUAL FILE SYSTEM" .PP When a zipfile is concatenated to the end of a \fBtclsh\fR, on startup the contents of the zip archive will be mounted under a virtual file system (VFS). The root of that VFS can be retrieved using the \fBzipfs root\fR command. The zip archive is mounted under the \fBapp\fR directory within the VFS. If a file named \fBmain.tcl\fR is present in the top level directory of the zip archive, it will be sourced instead of tclsh's normal command line handing. If a top level directory \fBtcl_library\fR is present in the zip archive, it will become the directory loaded as env(TCL_LIBRARY). If a file named \fBmain.tcl\fR is present in the top level directory of the zip archive, it will be sourced instead of the shell's normal command line handling. .PP Only one zipfile can be concatenated to the end of executable image (tclsh, or wish). However, if multiple zipfiles are concatenated, only the last one is used. This filesystem is read-only. Files cannot be added or modified within this mounted file system. See zipfs(n) for complete details. .SH "SEE ALSO" auto_path(n), encoding(n), env(n), fconfigure(n), zipfs(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell, zipfs |
Changes to doc/tcltest.n.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | \fBtcltest::skipDirectories \fR?\fIpatternList\fR? \fBtcltest::skipFiles \fR?\fIpatternList\fR? \fBtcltest::temporaryDirectory \fR?\fIdirectory\fR? \fBtcltest::testsDirectory \fR?\fIdirectory\fR? \fBtcltest::verbose \fR?\fIlevel\fR? \fBtcltest::test \fIname description optionList\fR | < | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | \fBtcltest::skipDirectories \fR?\fIpatternList\fR? \fBtcltest::skipFiles \fR?\fIpatternList\fR? \fBtcltest::temporaryDirectory \fR?\fIdirectory\fR? \fBtcltest::testsDirectory \fR?\fIdirectory\fR? \fBtcltest::verbose \fR?\fIlevel\fR? \fBtcltest::test \fIname description optionList\fR \fBtcltest::normalizeMsg \fImsg\fR \fBtcltest::normalizePath \fIpathVar\fR \fBtcltest::workingDirectory \fR?\fIdir\fR? .fi .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
451 452 453 454 455 456 457 | .TP \fBnormalizePath \fIpathVar\fR . Resolves symlinks in a path, thus creating a path without internal redirection. It is assumed that \fIpathVar\fR is absolute. \fIpathVar\fR is modified in place. The Tcl command \fBfile normalize\fR is a sufficient replacement. | < < < < < < < < < < < < | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 | .TP \fBnormalizePath \fIpathVar\fR . Resolves symlinks in a path, thus creating a path without internal redirection. It is assumed that \fIpathVar\fR is absolute. \fIpathVar\fR is modified in place. The Tcl command \fBfile normalize\fR is a sufficient replacement. .SH TESTS .PP The \fBtest\fR command is the heart of the \fBtcltest\fR package. Its essential function is to evaluate a Tcl script and compare the result with an expected result. The options of \fBtest\fR define the test script, the environment in which to evaluate it, the expected result, and how the compare the actual result to |
| ︙ | ︙ |
Changes to doc/tclvars.n.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | If set, then it must contain a valid Tcl list giving directories to search during auto-load operations (including for package index files when using the default \fBpackage unknown\fR handler). This variable is initialized during startup to contain, in order: the directories listed in the \fBTCLLIBPATH\fR environment variable, the directory named by the \fBtcl_library\fR global variable, the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. Additional locations to look for files and package indices should normally be added to this variable using \fBlappend\fR. Initialization of auto_path from the TCLLIBPATH environment variable undergoes tilde substitution (see \fBfilename\fR) on each path. Any tilde substitution that fails because the user is unknown will be omitted from auto_path. | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | If set, then it must contain a valid Tcl list giving directories to search during auto-load operations (including for package index files when using the default \fBpackage unknown\fR handler). This variable is initialized during startup to contain, in order: the directories listed in the \fBTCLLIBPATH\fR environment variable, the directory named by the \fBtcl_library\fR global variable, the parent directory of \fBtcl_library\fR, \fB[file dirname [file dirname [info nameofexecutable]]]/lib\fR, the directories listed in the \fBtcl_pkgPath\fR variable. Additional locations to look for files and package indices should normally be added to this variable using \fBlappend\fR. Initialization of auto_path from the TCLLIBPATH environment variable undergoes tilde substitution (see \fBfilename\fR) on each path. Any tilde substitution that fails because the user is unknown will be omitted from auto_path. |
| ︙ | ︙ | |||
392 393 394 395 396 397 398 | .\" VARIABLE: tcl_wordchars .TP \fBtcl_wordchars\fR . The value of this variable is a regular expression that can be set to control what are considered .QW word | < < < | | < < < | | 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | .\" VARIABLE: tcl_wordchars .TP \fBtcl_wordchars\fR . The value of this variable is a regular expression that can be set to control what are considered .QW word characters. It defaults to \fB\ew\fR, which is any Unicode word character (number, letter, or underscore). .\" VARIABLE: tcl_nonwordchars .TP \fBtcl_nonwordchars\fR . The value of this variable is a regular expression that can be set to control what are considered .QW non-word characters. It defaults to \fB\eW\fR, which is anything but a Unicode word character (number, letter, or underscore). .\" VARIABLE: tcl_version .TP \fBtcl_version\fR . When an interpreter is created Tcl initializes this variable to hold the version number for this version of Tcl in the form \fIx.y\fR. |
| ︙ | ︙ |
Changes to doc/tell.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH tell n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel .SH SYNOPSIS | | < < < < < < < < < < < < < < < < < | < < < < < < < < > < < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | .TH tell n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel .SH SYNOPSIS \fBtell \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBtell\fR command has been superceded by the \fBchan tell\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/tm.n.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | .SH NAME tm \- Facilities for locating and loading of Tcl Modules .SH SYNOPSIS .nf \fB::tcl::tm::path add \fR?\fIpath\fR...? \fB::tcl::tm::path remove \fR?\fIpath\fR...? \fB::tcl::tm::path list\fR | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | .SH NAME tm \- Facilities for locating and loading of Tcl Modules .SH SYNOPSIS .nf \fB::tcl::tm::path add \fR?\fIpath\fR...? \fB::tcl::tm::path remove \fR?\fIpath\fR...? \fB::tcl::tm::path list\fR \fB::tcl::tm::roots \fR\fIpaths\fR .fi .BE .SH DESCRIPTION .PP This document describes the facilities for locating and loading Tcl Modules (see \fBMODULE DEFINITION\fR for the definition of a Tcl Module). The following commands are supported: |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | .TP \fB::tcl::tm::path list\fR . Returns a list containing all registered module paths, in the order that they are searched for modules. .\" COMMAND: roots .TP | | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | .TP \fB::tcl::tm::path list\fR . Returns a list containing all registered module paths, in the order that they are searched for modules. .\" COMMAND: roots .TP \fB::tcl::tm::roots \fR\fIpaths\fR . Similar to \fBpath add\fR, and layered on top of it. This command takes a single argument containing a list of paths, extends each with .QW "\fBtcl\fIX\fB/site-tcl\fR" , and .QW "\fBtcl\fIX\fB/\fIX\fB.\fIy\fR" , for major version \fIX\fR of the Tcl interpreter and minor version \fIy\fR less than or equal to the minor version of the interpreter, and adds the resulting set of paths to the list of paths to search. |
| ︙ | ︙ | |||
286 287 288 289 290 291 292 | variable has been kept only for backward compatibility with the original specification, i.e. TIP 189. .PP These paths are seen and therefore shared by all Tcl shells in the \fB$::env(PATH)\fR of the user. .PP Note that \fIX\fR and \fIy\fR follow the general rules set out | | < < < | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 | variable has been kept only for backward compatibility with the original specification, i.e. TIP 189. .PP These paths are seen and therefore shared by all Tcl shells in the \fB$::env(PATH)\fR of the user. .PP Note that \fIX\fR and \fIy\fR follow the general rules set out above. In other words, Tcl 9.1, for example, will look at these 4 environment variables: .PP .CS \fB$::env(TCL9.1_TM_PATH)\fR \fB$::env(TCL9_1_TM_PATH)\fR \fB$::env(TCL9.0_TM_PATH)\fR \fB$::env(TCL9_0_TM_PATH)\fR .CE .PP Paths initialized from the environment variables undergo tilde substitution (see \fBfilename\fR). Any path whose tilde substitution fails because the user is unknown will be omitted from search paths. .SH "SEE ALSO" package(n), Tcl Improvement Proposal #189 |
| ︙ | ︙ |
Changes to doc/transchan.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME transchan \- command handler API of channel transforms .SH SYNOPSIS .nf | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME transchan \- command handler API of channel transforms .SH SYNOPSIS .nf \fBchan push \fIchannel cmdPrefix\fR \fIcmdPrefix \fBclear \fIhandle\fR \fIcmdPrefix \fBdrain \fIhandle\fR \fIcmdPrefix \fBfinalize \fIhandle\fR \fIcmdPrefix \fBflush \fIhandle\fR \fIcmdPrefix \fBinitialize \fIhandle mode\fR \fIcmdPrefix \fBlimit? \fIhandle\fR |
| ︙ | ︙ |
Changes to doc/try.n.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
\fBtry\fR {
set f [open /some/file/name r]
} \fBtrap\fR {POSIX EISDIR} {} {
puts "failed to open /some/file/name: it's a directory"
} \fBtrap\fR {POSIX ENOENT} {} {
puts "failed to open /some/file/name: it doesn't exist"
}
.CE
.SH "SEE ALSO"
catch(n), error(n), return(n), throw(n)
.SH "KEYWORDS"
cleanup, error, exception, final, resource management
'\" Local Variables:
'\" mode: nroff
| > > > > > > > > > > > > > > > > > | 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 |
\fBtry\fR {
set f [open /some/file/name r]
} \fBtrap\fR {POSIX EISDIR} {} {
puts "failed to open /some/file/name: it's a directory"
} \fBtrap\fR {POSIX ENOENT} {} {
puts "failed to open /some/file/name: it doesn't exist"
}
.CE
.PP
Proc to read a file in utf-8 encoding and return its contents.
The file is closed in success and error case by the finally clause.
It is allowed to call \fBreturn\fR within the \fBtry\fR block.
Remark that with tcl 9, the read command may also throw utf-8 conversion errors:
.PP
.CS
proc readfile {filename} {
set f [open $filename r]
\fBtry\fR {
fconfigure $f -encoding utf-8 -profile strict
\fBreturn\fR [read $f]
} \fBfinally\fR {
close $f
}
}
.CE
.SH "SEE ALSO"
catch(n), error(n), return(n), throw(n)
.SH "KEYWORDS"
cleanup, error, exception, final, resource management
'\" Local Variables:
'\" mode: nroff
|
| ︙ | ︙ |
Changes to doc/unknown.n.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | The result of the \fBunknown\fR command is used as the result for the original non-existent command. .PP The default implementation of \fBunknown\fR behaves as follows. It first calls the \fBauto_load\fR library procedure to load the command. If this succeeds, then it executes the original command with its original arguments. | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | The result of the \fBunknown\fR command is used as the result for the original non-existent command. .PP The default implementation of \fBunknown\fR behaves as follows. It first calls the \fBauto_load\fR library procedure to load the command. If this succeeds, then it executes the original command with its original arguments. If the auto-load fails and Tcl is run interactively then \fBunknown\fR calls \fBauto_execok\fR to see if there is an executable file by the name \fIcmd\fR. If so, it invokes the Tcl \fBexec\fR command with \fIcmd\fR and all the \fIargs\fR as arguments. If \fIcmd\fR cannot be auto-executed, \fBunknown\fR checks to see if the command was invoked at top-level and outside of any script. If so, then \fBunknown\fR takes two additional steps. First, it sees if \fIcmd\fR has one of the following three forms: |
| ︙ | ︙ |
Changes to doc/zipfs.3.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com> '\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de> '\" Copyright (c) 2017 Sean Woods <yoda@etoyoc.com> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com> '\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de> '\" Copyright (c) 2017 Sean Woods <yoda@etoyoc.com> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tclzipfs 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME TclZipfs_AppHook, TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount \- handle ZIP files as Tcl virtual filesystems .SH SYNOPSIS .nf const char * |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | .BE .SH DESCRIPTION \fBTclZipfs_AppHook\fR is a utility function to perform standard application initialization procedures, taking into account available ZIP archives as follows: .IP [1] If the current application has a mountable ZIP archive, that archive is | | | > | | | | | | | > > > | | 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 | .BE .SH DESCRIPTION \fBTclZipfs_AppHook\fR is a utility function to perform standard application initialization procedures, taking into account available ZIP archives as follows: .IP [1] If the current application has a mountable ZIP archive, that archive is mounted under \fIZIPFS_VOLUME\fB/app\fR as a read-only Tcl virtual file system (VFS). The value of \fIZIPFS_VOLUME\fR can be retrieved using the Tcl command \fBzipfs root\fR. .IP [2] If a file named \fBmain.tcl\fR is located in the root directory of that file system (i.e., at \fIZIPFS_VOLUME\fB/app/main.tcl\fR after the ZIP archive is mounted as described above) it is treated as the startup script for the process. .IP [3] If the file \fIZIPFS_VOLUME\fB/app/tcl_library/init.tcl\fR is present, the \fBtcl_library\fR global variable in the initial Tcl interpreter is set to \fIZIPFS_VOLUME\fB/app/tcl_library\fR. .IP [4] If the directory \fBtcl_library\fR was not found in the main application mount, the system will then search for it as either a VFS attached to the application dynamic library, or as a zip archive named \fBlibtcl_\fImajor\fB_\fIminor\fB_\fIpatchlevel\fB.zip\fR either in the present working directory or in the standard Tcl install location. (For example, the Tcl 9.0.2 release would be searched for in a file \fBlibtcl_9_0_2.zip\fR.) That archive, if located, is also mounted read-only. .PP On Windows, \fBTclZipfs_AppHook\fR has a slightly different signature, since it uses WCHAR instead of char. As a result, it requires the application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB\-DUNICODE\fR compiler flag). .PP The result of \fBTclZipfs_AppHook\fR is the full Tcl version with build information (e.g., \fB9.0.0+abcdef...abcdef.gcc-1002\fR). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume that this will be true in the future. .PP \fBTclZipfs_Mount\fR is used to mount ZIP archives and to retrieve information about currently mounted archives. If \fImountpoint\fR and \fIzipname\fR are both specified (i.e. non-NULL), the function mounts the ZIP archive \fIzipname\fR on the mount point given in \fImountpoint\fR. If \fIpassword\fR is not NULL, it should point to the NUL terminated password protecting the archive. If not under the zipfs file system root, \fImountpoint\fR is normalized with respect to it. For example, a mount point passed as either \fBmt\fR or \fB/mt\fR would be normalized to \fB//zipfs:/mt\fR, given that \fIZIPFS_VOLUME\fR as returned by \fBzipfs root\fR is .QW //zipfs:/ . An error is raised if the mount point includes a drive or UNC volume. On success, \fIinterp\fR's result is set to the normalized mount point path. .PP If \fImountpoint\fR is a NULL pointer, information on all currently mounted ZIP file systems is stored in \fIinterp\fR's result as a sequence of mount points and ZIP file names. .PP |
| ︙ | ︙ |
Changes to doc/zipfs.n.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME zipfs \- Mount and work with ZIP files within Tcl .SH SYNOPSIS .nf | < < | | > < < | | < | 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 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME zipfs \- Mount and work with ZIP files within Tcl .SH SYNOPSIS .nf \fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR \fBzipfs exists\fI filename\fR \fBzipfs find\fI directoryName\fR \fBzipfs info\fI filename\fR \fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? \fBzipfs lmkimg\fI outfile inlist\fR ?\fIpassword\fR? ?\fIinfile\fR? \fBzipfs lmkzip\fI outfile inlist\fR ?\fIpassword\fR? \fBzipfs mkimg\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? \fBzipfs mkkey\fI password\fR \fBzipfs mkzip\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? \fBzipfs mount\fR ?\fIzipfile\fR? ?\fImountpoint\fR? ?\fIpassword\fR? \fBzipfs mountdata\fR \fIdata\fR \fImountpoint\fR \fBzipfs root\fR \fBzipfs unmount\fI mountpoint\fR .fi .BE .SH DESCRIPTION .PP The \fBzipfs\fR command provides Tcl with the ability to mount the contents of a ZIP archive file as a virtual file system. Tcl's ZIP archive support is limited to basic features and options. Supported storage methods include only STORE and DEFLATE with optional simple encryption, sufficient to prevent casual inspection of their contents but not able to prevent access by even a moderately determined attacker. Strong encryption, multi-part archives, platform metadata, zip64 formats and other compression methods like bzip2 are not supported. .PP Files within mounted archives can be written to but new files or directories cannot be created. Further, modifications to files are limited to the mounted archive in memory and are not persisted to disk. .PP Paths in mounted archives are case-sensitive on all platforms. .\" METHOD: canonical .TP \fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR . This takes the name of a file, \fIfilename\fR, and produces where it would be mapped into a zipfs mount as its result. If specified, \fImountpoint\fR says within which mount the mapping will be done; if omitted, the main root of the zipfs system is used. .\" METHOD: exists .TP \fBzipfs exists\fI filename\fR . Return 1 if the given filename exists in the mounted zipfs and 0 if it does not. .\" METHOD: find .TP |
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | virtual filesystem at \fImountpoint\fR. After this command executes, files contained in \fIzipfile\fR will appear to Tcl to be regular files at the mount point. If \fImountpoint\fR is specified as an empty string, it is defaulted to the \fB[zipfs root]\fR. The command returns the normalized mount point path. .PP If not under the zipfs file system root, \fImountpoint\fR is normalized with | | | > > | > > > > > | < < | | | > | > | | | > > > > > > > > > | > > > > > | 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 | virtual filesystem at \fImountpoint\fR. After this command executes, files contained in \fIzipfile\fR will appear to Tcl to be regular files at the mount point. If \fImountpoint\fR is specified as an empty string, it is defaulted to the \fB[zipfs root]\fR. The command returns the normalized mount point path. .PP If not under the zipfs file system root, \fImountpoint\fR is normalized with respect to it. For example, a mount point passed as either \fBmt\fR or \fB/mt\fR would be normalized to \fB//zipfs:/mt\fR (given that \fBzipfs root\fR returns .QW //zipfs:/ ). An error is raised if the mount point includes a drive or UNC volume. .PP \fBNB:\fR because the current working directory is a concept maintained by the operating system, using \fBcd\fR into a mounted archive will only work in the current process, and then not entirely consistently (e.g., if a shared library uses direct access to the OS rather than through Tcl's filesystem API, it will not see the current directory as being inside the mount and will not be able to access the files inside the mount). .RE .\" METHOD: mountdata .TP \fBzipfs mountdata\fR \fIdata\fR \fImountpoint\fR Mounts the ZIP archive content \fIdata\fR as a Tcl virtual filesystem at \fImountpoint\fR. .\" METHOD: root .TP \fBzipfs root\fR . Returns a constant string which indicates the mount point for zipfs volumes for the current platform. User should not rely on the mount point being the same constant string for all platforms. .\" METHOD: unmount .TP \fBzipfs unmount \fImountpoint\fR . Unmounts a previously mounted ZIP archive mounted to \fImountpoint\fR. The command will fail with an error exception if there are any files within the mounted archive are open. .SS "ZIP CREATION COMMANDS" This package also provides several commands to aid the creation of ZIP archives as Tcl applications. .\" METHOD: mkzip .TP \fBzipfs mkzip\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? . Creates a ZIP archive file named \fIoutfile\fR from the contents of the input directory \fIindir\fR (contained regular files only) with optional ZIP password \fIpassword\fR. While processing the files below \fIindir\fR the optional file name prefix given in \fIstrip\fR is stripped off the beginning of the respective file name if non-empty. When stripping, it is common to remove either the whole source directory name or the name of its parent directory. .RS .PP \fBCaution:\fR the choice of the \fIindir\fR parameter (less the optional stripped prefix) determines the later root name of the archive's content. .RE .\" METHOD: mkimg .TP \fBzipfs mkimg\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? . Creates an image (potentially a new executable file) similar to \fBzipfs mkzip\fR; see that command for a description of most parameters to this command, as they behave identically here. If \fIoutfile\fR exists, it will be silently overwritten. .RS .PP If the \fIinfile\fR parameter is specified, this file is prepended in front of the ZIP archive, otherwise the file returned by \fBinfo nameofexecutable\fR (i.e., the executable file of the running process, typically \fBwish\fR or \fBtclsh\fR) is used. If the \fIpassword\fR parameter is not the empty string, an obfuscated version of that password (see \fBzipfs mkkey\fR) is placed between the image and ZIP chunks of the output file and the contents of the ZIP chunk are protected with that password. If the starting image has a ZIP archive already attached to it, it is removed from the copy in \fIoutfile\fR before the new ZIP archive is added. .PP If there is a file, \fBmain.tcl\fR, in the root directory of the resulting archive and the image file that the archive is attached to is a \fBtclsh\fR (or \fBwish\fR) instance (true by default, but depends on your configuration), then the resulting image is an executable that will \fBsource\fR the script in that \fBmain.tcl\fR after mounting the ZIP archive, and will \fBexit\fR once that script has been executed. .PP \fBNote:\fR \fBtclsh\fR and \fBwish\fR can be built using either dynamic binding or static binding of the core implementation libraries. With a dynamic binding, the base application Tcl_Library contents are attached to the \fBlibtcl\fR and \fBlibtk\fR shared library, respectively. With a static binding, the Tcl_Library contents, etc., are attached to the application, \fBtclsh\fR or \fBwish\fR. When using \fBmkimg\fR with a statically built tclsh, it is the user's responsibility to preserve the attached archive by first extracting it to a temporary location, and then add whatever additional files desired, before creating and attaching the new archive to the new application. .RE .\" METHOD: mkkey .TP \fBzipfs mkkey\fI password\fR . Given the clear text \fIpassword\fR argument, an obfuscated string version is returned with the same format used in the \fBzipfs mkimg\fR command. .\" METHOD: lmkimg .TP \fBzipfs lmkimg\fI outfile inlist\fR ?\fIpassword\fR? ?\fIinfile\fR? . This command is like \fBzipfs mkimg\fR, but instead of an input directory, \fIinlist\fR must be a Tcl list where the odd elements are the names of files to be copied into the archive in the image, and the even elements are their respective names within that archive. .\" METHOD: lmkzip .TP \fBzipfs lmkzip\fI outfile inlist\fR ?\fIpassword\fR? . This command is like \fBzipfs mkzip\fR, but instead of an input directory, \fIinlist\fR must be a Tcl list where the odd elements are the names of files to be copied into the archive, and the even elements are their respective names within that archive. .SH "NOTE" .PP The current syntax for certain subcommands using multiple optional parameters might change in the future to support an \fI?-option value?\fR pattern instead. Therfore, the current syntax should not be considered stable. .SH "EXAMPLES" .PP Mounting an ZIP archive as an application directory and running code out of it before unmounting it again: .PP .CS set zip myApp.zip |
| ︙ | ︙ | |||
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 | # Create with password \fBzipfs mkzip\fR $targetZip $sourceDir $sourceDir $password # Mount with password \fBzipfs mount\fR $zip $base $password .CE .PP When creating an executable image with a password, the password is placed within the executable in a shrouded form so that the application can read files inside the embedded ZIP archive yet casual inspection cannot read it. .PP .CS set appDir [file normalize myApp] set img "myApp.bin" set password "hunter2" # Create some simple content to define a basic application file mkdir $appDir | > > > > | | > > > > | | 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 |
# Create with password
\fBzipfs mkzip\fR $targetZip $sourceDir $sourceDir $password
# Mount with password
\fBzipfs mount\fR $zip $base $password
.CE
.PP
The following example creates an executable application by appending a ZIP archive
to the tclsh file it was called from and storing the resulting executable in
the file
.QW myApp.bin .
When creating an executable image with a password, the password is placed
within the executable in a shrouded form so that the application can read
files inside the embedded ZIP archive yet casual inspection cannot read it.
.PP
.CS
set appDir [file normalize myApp]
set img "myApp.bin"
set password "hunter2"
# Create some simple content to define a basic application
file mkdir $appDir
set f [open $appDir/main.tcl w]
puts $f {
puts "Hi. This is [info script]"
}
close $f
# Create the executable application
\fBzipfs mkimg\fR $img $appDir $appDir $password
# remove the now obsolete temporary appDir folder
file delete -force $appDir
# Launch the executable, printing its output to stdout
exec $img >@stdout
# prints the following line assuming [zipfs root] returns "//zipfs:/":
# \fIHi. This is //zipfs:/app/main.tcl\fR
.CE
.SH "SEE ALSO"
tclsh(1), file(n), zipfs(3), zlib(n)
.SH "KEYWORDS"
compress, filesystem, zip
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to generic/regc_color.c.
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
return sco;
}
/*
- subrange - allocate new subcolors to this range of chrs, fill in arcs
^ static void subrange(struct vars *, pchr, pchr, struct state *,
| | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 |
return sco;
}
/*
- subrange - allocate new subcolors to this range of chrs, fill in arcs
^ static void subrange(struct vars *, pchr, pchr, struct state *,
^ struct state *);
*/
static void
subrange(
struct vars *v,
pchr from,
pchr to,
struct state *lp,
|
| ︙ | ︙ | |||
685 686 687 688 689 690 691 |
a->colorchain = NULL; /* paranoia */
a->colorchainRev = NULL;
}
/*
- rainbow - add arcs of all full colors (but one) between specified states
^ static void rainbow(struct nfa *, struct colormap *, int, pcolor,
| | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
a->colorchain = NULL; /* paranoia */
a->colorchainRev = NULL;
}
/*
- rainbow - add arcs of all full colors (but one) between specified states
^ static void rainbow(struct nfa *, struct colormap *, int, pcolor,
^ struct state *, struct state *);
*/
static void
rainbow(
struct nfa *nfa,
struct colormap *cm,
int type,
pcolor but, /* COLORLESS if no exceptions */
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
}
}
/*
- colorcomplement - add arcs of complementary colors
* The calling sequence ought to be reconciled with cloneouts().
^ static void colorcomplement(struct nfa *, struct colormap *, int,
| | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 |
}
}
/*
- colorcomplement - add arcs of complementary colors
* The calling sequence ought to be reconciled with cloneouts().
^ static void colorcomplement(struct nfa *, struct colormap *, int,
^ struct state *, struct state *, struct state *);
*/
static void
colorcomplement(
struct nfa *nfa,
struct colormap *cm,
int type,
struct state *of, /* complements of this guy's PLAIN outarcs */
|
| ︙ | ︙ |
Changes to generic/regc_locale.c.
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
{0x1401, 0x166C}, {0x166F, 0x167F}, {0x1681, 0x169A}, {0x16A0, 0x16EA},
{0x16F1, 0x16F8}, {0x1700, 0x1711}, {0x171F, 0x1731}, {0x1740, 0x1751},
{0x1760, 0x176C}, {0x176E, 0x1770}, {0x1780, 0x17B3}, {0x1820, 0x1878},
{0x1880, 0x1884}, {0x1887, 0x18A8}, {0x18B0, 0x18F5}, {0x1900, 0x191E},
{0x1950, 0x196D}, {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9},
{0x1A00, 0x1A16}, {0x1A20, 0x1A54}, {0x1B05, 0x1B33}, {0x1B45, 0x1B4C},
{0x1B83, 0x1BA0}, {0x1BBA, 0x1BE5}, {0x1C00, 0x1C23}, {0x1C4D, 0x1C4F},
| | | | 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 |
{0x1401, 0x166C}, {0x166F, 0x167F}, {0x1681, 0x169A}, {0x16A0, 0x16EA},
{0x16F1, 0x16F8}, {0x1700, 0x1711}, {0x171F, 0x1731}, {0x1740, 0x1751},
{0x1760, 0x176C}, {0x176E, 0x1770}, {0x1780, 0x17B3}, {0x1820, 0x1878},
{0x1880, 0x1884}, {0x1887, 0x18A8}, {0x18B0, 0x18F5}, {0x1900, 0x191E},
{0x1950, 0x196D}, {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9},
{0x1A00, 0x1A16}, {0x1A20, 0x1A54}, {0x1B05, 0x1B33}, {0x1B45, 0x1B4C},
{0x1B83, 0x1BA0}, {0x1BBA, 0x1BE5}, {0x1C00, 0x1C23}, {0x1C4D, 0x1C4F},
{0x1C5A, 0x1C7D}, {0x1C80, 0x1C8A}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CBF},
{0x1CE9, 0x1CEC}, {0x1CEE, 0x1CF3}, {0x1D00, 0x1DBF}, {0x1E00, 0x1F15},
{0x1F18, 0x1F1D}, {0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, {0x1F50, 0x1F57},
{0x1F5F, 0x1F7D}, {0x1F80, 0x1FB4}, {0x1FB6, 0x1FBC}, {0x1FC2, 0x1FC4},
{0x1FC6, 0x1FCC}, {0x1FD0, 0x1FD3}, {0x1FD6, 0x1FDB}, {0x1FE0, 0x1FEC},
{0x1FF2, 0x1FF4}, {0x1FF6, 0x1FFC}, {0x2090, 0x209C}, {0x210A, 0x2113},
{0x2119, 0x211D}, {0x212A, 0x212D}, {0x212F, 0x2139}, {0x213C, 0x213F},
{0x2145, 0x2149}, {0x2C00, 0x2CE4}, {0x2CEB, 0x2CEE}, {0x2D00, 0x2D25},
{0x2D30, 0x2D67}, {0x2D80, 0x2D96}, {0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE},
{0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE}, {0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE},
{0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE}, {0x3031, 0x3035}, {0x3041, 0x3096},
{0x309D, 0x309F}, {0x30A1, 0x30FA}, {0x30FC, 0x30FF}, {0x3105, 0x312F},
{0x3131, 0x318E}, {0x31A0, 0x31BF}, {0x31F0, 0x31FF}, {0x3400, 0x4DBF},
{0x4E00, 0xA48C}, {0xA4D0, 0xA4FD}, {0xA500, 0xA60C}, {0xA610, 0xA61F},
{0xA640, 0xA66E}, {0xA67F, 0xA69D}, {0xA6A0, 0xA6E5}, {0xA717, 0xA71F},
{0xA722, 0xA788}, {0xA78B, 0xA7CD}, {0xA7D5, 0xA7DC}, {0xA7F2, 0xA801},
{0xA803, 0xA805}, {0xA807, 0xA80A}, {0xA80C, 0xA822}, {0xA840, 0xA873},
{0xA882, 0xA8B3}, {0xA8F2, 0xA8F7}, {0xA90A, 0xA925}, {0xA930, 0xA946},
{0xA960, 0xA97C}, {0xA984, 0xA9B2}, {0xA9E0, 0xA9E4}, {0xA9E6, 0xA9EF},
{0xA9FA, 0xA9FE}, {0xAA00, 0xAA28}, {0xAA40, 0xAA42}, {0xAA44, 0xAA4B},
{0xAA60, 0xAA76}, {0xAA7E, 0xAAAF}, {0xAAB9, 0xAABD}, {0xAADB, 0xAADD},
{0xAAE0, 0xAAEA}, {0xAAF2, 0xAAF4}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E},
{0xAB11, 0xAB16}, {0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB5A},
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
#if CHRBITS > 16
,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D},
{0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10280, 0x1029C}, {0x102A0, 0x102D0},
{0x10300, 0x1031F}, {0x1032D, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375},
{0x10380, 0x1039D}, {0x103A0, 0x103C3}, {0x103C8, 0x103CF}, {0x10400, 0x1049D},
{0x104B0, 0x104D3}, {0x104D8, 0x104FB}, {0x10500, 0x10527}, {0x10530, 0x10563},
{0x10570, 0x1057A}, {0x1057C, 0x1058A}, {0x1058C, 0x10592}, {0x10597, 0x105A1},
| | | | | | | | | > | > | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | 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 |
#if CHRBITS > 16
,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D},
{0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10280, 0x1029C}, {0x102A0, 0x102D0},
{0x10300, 0x1031F}, {0x1032D, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375},
{0x10380, 0x1039D}, {0x103A0, 0x103C3}, {0x103C8, 0x103CF}, {0x10400, 0x1049D},
{0x104B0, 0x104D3}, {0x104D8, 0x104FB}, {0x10500, 0x10527}, {0x10530, 0x10563},
{0x10570, 0x1057A}, {0x1057C, 0x1058A}, {0x1058C, 0x10592}, {0x10597, 0x105A1},
{0x105A3, 0x105B1}, {0x105B3, 0x105B9}, {0x105C0, 0x105F3}, {0x10600, 0x10736},
{0x10740, 0x10755}, {0x10760, 0x10767}, {0x10780, 0x10785}, {0x10787, 0x107B0},
{0x107B2, 0x107BA}, {0x10800, 0x10805}, {0x1080A, 0x10835}, {0x1083F, 0x10855},
{0x10860, 0x10876}, {0x10880, 0x1089E}, {0x108E0, 0x108F2}, {0x10900, 0x10915},
{0x10920, 0x10939}, {0x10980, 0x109B7}, {0x10A10, 0x10A13}, {0x10A15, 0x10A17},
{0x10A19, 0x10A35}, {0x10A60, 0x10A7C}, {0x10A80, 0x10A9C}, {0x10AC0, 0x10AC7},
{0x10AC9, 0x10AE4}, {0x10B00, 0x10B35}, {0x10B40, 0x10B55}, {0x10B60, 0x10B72},
{0x10B80, 0x10B91}, {0x10C00, 0x10C48}, {0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2},
{0x10D00, 0x10D23}, {0x10D4A, 0x10D65}, {0x10D6F, 0x10D85}, {0x10E80, 0x10EA9},
{0x10EC2, 0x10EC4}, {0x10F00, 0x10F1C}, {0x10F30, 0x10F45}, {0x10F70, 0x10F81},
{0x10FB0, 0x10FC4}, {0x10FE0, 0x10FF6}, {0x11003, 0x11037}, {0x11083, 0x110AF},
{0x110D0, 0x110E8}, {0x11103, 0x11126}, {0x11150, 0x11172}, {0x11183, 0x111B2},
{0x111C1, 0x111C4}, {0x11200, 0x11211}, {0x11213, 0x1122B}, {0x11280, 0x11286},
{0x1128A, 0x1128D}, {0x1128F, 0x1129D}, {0x1129F, 0x112A8}, {0x112B0, 0x112DE},
{0x11305, 0x1130C}, {0x11313, 0x11328}, {0x1132A, 0x11330}, {0x11335, 0x11339},
{0x1135D, 0x11361}, {0x11380, 0x11389}, {0x11390, 0x113B5}, {0x11400, 0x11434},
{0x11447, 0x1144A}, {0x1145F, 0x11461}, {0x11480, 0x114AF}, {0x11580, 0x115AE},
{0x115D8, 0x115DB}, {0x11600, 0x1162F}, {0x11680, 0x116AA}, {0x11700, 0x1171A},
{0x11740, 0x11746}, {0x11800, 0x1182B}, {0x118A0, 0x118DF}, {0x118FF, 0x11906},
{0x1190C, 0x11913}, {0x11918, 0x1192F}, {0x119A0, 0x119A7}, {0x119AA, 0x119D0},
{0x11A0B, 0x11A32}, {0x11A5C, 0x11A89}, {0x11AB0, 0x11AF8}, {0x11BC0, 0x11BE0},
{0x11C00, 0x11C08}, {0x11C0A, 0x11C2E}, {0x11C72, 0x11C8F}, {0x11D00, 0x11D06},
{0x11D0B, 0x11D30}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D89}, {0x11EE0, 0x11EF2},
{0x11F04, 0x11F10}, {0x11F12, 0x11F33}, {0x12000, 0x12399}, {0x12480, 0x12543},
{0x12F90, 0x12FF0}, {0x13000, 0x1342F}, {0x13441, 0x13446}, {0x13460, 0x143FA},
{0x14400, 0x14646}, {0x16100, 0x1611D}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E},
{0x16A70, 0x16ABE}, {0x16AD0, 0x16AED}, {0x16B00, 0x16B2F}, {0x16B40, 0x16B43},
{0x16B63, 0x16B77}, {0x16B7D, 0x16B8F}, {0x16D40, 0x16D6C}, {0x16E40, 0x16E7F},
{0x16F00, 0x16F4A}, {0x16F93, 0x16F9F}, {0x17000, 0x187F7}, {0x18800, 0x18CD5},
{0x18CFF, 0x18D08}, {0x1AFF0, 0x1AFF3}, {0x1AFF5, 0x1AFFB}, {0x1B000, 0x1B122},
{0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB}, {0x1BC00, 0x1BC6A},
{0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99}, {0x1D400, 0x1D454},
{0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3},
{0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A}, {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C},
{0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E}, {0x1D540, 0x1D544}, {0x1D54A, 0x1D550},
{0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D6C0}, {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6FA},
{0x1D6FC, 0x1D714}, {0x1D716, 0x1D734}, {0x1D736, 0x1D74E}, {0x1D750, 0x1D76E},
{0x1D770, 0x1D788}, {0x1D78A, 0x1D7A8}, {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7CB},
{0x1DF00, 0x1DF1E}, {0x1DF25, 0x1DF2A}, {0x1E030, 0x1E06D}, {0x1E100, 0x1E12C},
{0x1E137, 0x1E13D}, {0x1E290, 0x1E2AD}, {0x1E2C0, 0x1E2EB}, {0x1E4D0, 0x1E4EB},
{0x1E5D0, 0x1E5ED}, {0x1E7E0, 0x1E7E6}, {0x1E7E8, 0x1E7EB}, {0x1E7F0, 0x1E7FE},
{0x1E800, 0x1E8C4}, {0x1E900, 0x1E943}, {0x1EE00, 0x1EE03}, {0x1EE05, 0x1EE1F},
{0x1EE29, 0x1EE32}, {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A},
{0x1EE6C, 0x1EE72}, {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89},
{0x1EE8B, 0x1EE9B}, {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB},
{0x20000, 0x2A6DF}, {0x2A700, 0x2B739}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1},
{0x2CEB0, 0x2EBE0}, {0x2EBF0, 0x2EE5D}, {0x2F800, 0x2FA1D}, {0x30000, 0x3134A},
{0x31350, 0x323AF}
#endif
};
#define NUM_ALPHA_RANGE ((int)(sizeof(alphaRangeTable)/sizeof(crange)))
static const chr alphaCharTable[] = {
0xAA, 0xB5, 0xBA, 0x2EC, 0x2EE, 0x376, 0x377, 0x37F, 0x386,
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
0x2D6F, 0x2E2F, 0x3005, 0x3006, 0x303B, 0x303C, 0xA62A, 0xA62B, 0xA7D0,
0xA7D1, 0xA7D3, 0xA8FB, 0xA8FD, 0xA8FE, 0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5,
0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, 0x10838,
0x1083C, 0x108F4, 0x108F5, 0x109BE, 0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27,
0x11071, 0x11072, 0x11075, 0x11144, 0x11147, 0x11176, 0x111DA, 0x111DC, 0x1123F,
| | > | | | | | | | < | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
0x2D6F, 0x2E2F, 0x3005, 0x3006, 0x303B, 0x303C, 0xA62A, 0xA62B, 0xA7D0,
0xA7D1, 0xA7D3, 0xA8FB, 0xA8FD, 0xA8FE, 0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5,
0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, 0x10838,
0x1083C, 0x108F4, 0x108F5, 0x109BE, 0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27,
0x11071, 0x11072, 0x11075, 0x11144, 0x11147, 0x11176, 0x111DA, 0x111DC, 0x1123F,
0x11240, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x1133D, 0x11350, 0x1138B,
0x1138E, 0x113B7, 0x113D1, 0x113D3, 0x114C4, 0x114C5, 0x114C7, 0x11644, 0x116B8,
0x11909, 0x11915, 0x11916, 0x1193F, 0x11941, 0x119E1, 0x119E3, 0x11A00, 0x11A3A,
0x11A50, 0x11A9D, 0x11C40, 0x11D08, 0x11D09, 0x11D46, 0x11D67, 0x11D68, 0x11D98,
0x11F02, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1, 0x16FE3, 0x1AFFD, 0x1AFFE, 0x1B132,
0x1B155, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E14E,
0x1E5F0, 0x1E7ED, 0x1E7EE, 0x1E94B, 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39,
0x1EE3B, 0x1EE42, 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57,
0x1EE59, 0x1EE5B, 0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E
#endif
};
#define NUM_ALPHA_CHAR ((int)(sizeof(alphaCharTable)/sizeof(chr)))
/*
* Unicode: control characters.
|
| ︙ | ︙ | |||
328 329 330 331 332 333 334 |
{0xF20, 0xF29}, {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17E0, 0x17E9},
{0x1810, 0x1819}, {0x1946, 0x194F}, {0x19D0, 0x19D9}, {0x1A80, 0x1A89},
{0x1A90, 0x1A99}, {0x1B50, 0x1B59}, {0x1BB0, 0x1BB9}, {0x1C40, 0x1C49},
{0x1C50, 0x1C59}, {0xA620, 0xA629}, {0xA8D0, 0xA8D9}, {0xA900, 0xA909},
{0xA9D0, 0xA9D9}, {0xA9F0, 0xA9F9}, {0xAA50, 0xAA59}, {0xABF0, 0xABF9},
{0xFF10, 0xFF19}
#if CHRBITS > 16
| | | | > | | > | | | | | | | | | | | | | | | | > | | < | 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 |
{0xF20, 0xF29}, {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17E0, 0x17E9},
{0x1810, 0x1819}, {0x1946, 0x194F}, {0x19D0, 0x19D9}, {0x1A80, 0x1A89},
{0x1A90, 0x1A99}, {0x1B50, 0x1B59}, {0x1BB0, 0x1BB9}, {0x1C40, 0x1C49},
{0x1C50, 0x1C59}, {0xA620, 0xA629}, {0xA8D0, 0xA8D9}, {0xA900, 0xA909},
{0xA9D0, 0xA9D9}, {0xA9F0, 0xA9F9}, {0xAA50, 0xAA59}, {0xABF0, 0xABF9},
{0xFF10, 0xFF19}
#if CHRBITS > 16
,{0x104A0, 0x104A9}, {0x10D30, 0x10D39}, {0x10D40, 0x10D49}, {0x11066, 0x1106F},
{0x110F0, 0x110F9}, {0x11136, 0x1113F}, {0x111D0, 0x111D9}, {0x112F0, 0x112F9},
{0x11450, 0x11459}, {0x114D0, 0x114D9}, {0x11650, 0x11659}, {0x116C0, 0x116C9},
{0x116D0, 0x116E3}, {0x11730, 0x11739}, {0x118E0, 0x118E9}, {0x11950, 0x11959},
{0x11BF0, 0x11BF9}, {0x11C50, 0x11C59}, {0x11D50, 0x11D59}, {0x11DA0, 0x11DA9},
{0x11F50, 0x11F59}, {0x16130, 0x16139}, {0x16A60, 0x16A69}, {0x16AC0, 0x16AC9},
{0x16B50, 0x16B59}, {0x16D70, 0x16D79}, {0x1CCF0, 0x1CCF9}, {0x1D7CE, 0x1D7FF},
{0x1E140, 0x1E149}, {0x1E2F0, 0x1E2F9}, {0x1E4F0, 0x1E4F9}, {0x1E5F1, 0x1E5FA},
{0x1E950, 0x1E959}, {0x1FBF0, 0x1FBF9}
#endif
};
#define NUM_DIGIT_RANGE ((int)(sizeof(digitRangeTable)/sizeof(crange)))
/*
* no singletons of digit characters.
*/
/*
* Unicode: punctuation characters.
*/
static const crange punctRangeTable[] = {
{0x21, 0x23}, {0x25, 0x2A}, {0x2C, 0x2F}, {0x5B, 0x5D},
{0x55A, 0x55F}, {0x61D, 0x61F}, {0x66A, 0x66D}, {0x700, 0x70D},
{0x7F7, 0x7F9}, {0x830, 0x83E}, {0xF04, 0xF12}, {0xF3A, 0xF3D},
{0xFD0, 0xFD4}, {0x104A, 0x104F}, {0x1360, 0x1368}, {0x16EB, 0x16ED},
{0x17D4, 0x17D6}, {0x17D8, 0x17DA}, {0x1800, 0x180A}, {0x1AA0, 0x1AA6},
{0x1AA8, 0x1AAD}, {0x1B5A, 0x1B60}, {0x1B7D, 0x1B7F}, {0x1BFC, 0x1BFF},
{0x1C3B, 0x1C3F}, {0x1CC0, 0x1CC7}, {0x2010, 0x2027}, {0x2030, 0x2043},
{0x2045, 0x2051}, {0x2053, 0x205E}, {0x2308, 0x230B}, {0x2768, 0x2775},
{0x27E6, 0x27EF}, {0x2983, 0x2998}, {0x29D8, 0x29DB}, {0x2CF9, 0x2CFC},
{0x2E00, 0x2E2E}, {0x2E30, 0x2E4F}, {0x2E52, 0x2E5D}, {0x3001, 0x3003},
{0x3008, 0x3011}, {0x3014, 0x301F}, {0xA60D, 0xA60F}, {0xA6F2, 0xA6F7},
{0xA874, 0xA877}, {0xA8F8, 0xA8FA}, {0xA9C1, 0xA9CD}, {0xAA5C, 0xAA5F},
{0xFE10, 0xFE19}, {0xFE30, 0xFE52}, {0xFE54, 0xFE61}, {0xFF01, 0xFF03},
{0xFF05, 0xFF0A}, {0xFF0C, 0xFF0F}, {0xFF3B, 0xFF3D}, {0xFF5F, 0xFF65}
#if CHRBITS > 16
,{0x10100, 0x10102}, {0x10A50, 0x10A58}, {0x10AF0, 0x10AF6}, {0x10B39, 0x10B3F},
{0x10B99, 0x10B9C}, {0x10F55, 0x10F59}, {0x10F86, 0x10F89}, {0x11047, 0x1104D},
{0x110BE, 0x110C1}, {0x11140, 0x11143}, {0x111C5, 0x111C8}, {0x111DD, 0x111DF},
{0x11238, 0x1123D}, {0x1144B, 0x1144F}, {0x115C1, 0x115D7}, {0x11641, 0x11643},
{0x11660, 0x1166C}, {0x1173C, 0x1173E}, {0x11944, 0x11946}, {0x11A3F, 0x11A46},
{0x11A9A, 0x11A9C}, {0x11A9E, 0x11AA2}, {0x11B00, 0x11B09}, {0x11C41, 0x11C45},
{0x11F43, 0x11F4F}, {0x12470, 0x12474}, {0x16B37, 0x16B3B}, {0x16D6D, 0x16D6F},
{0x16E97, 0x16E9A}, {0x1DA87, 0x1DA8B}
#endif
};
#define NUM_PUNCT_RANGE ((int)(sizeof(punctRangeTable)/sizeof(crange)))
static const chr punctCharTable[] = {
0x3A, 0x3B, 0x3F, 0x40, 0x5F, 0x7B, 0x7D, 0xA1, 0xA7,
0xAB, 0xB6, 0xB7, 0xBB, 0xBF, 0x37E, 0x387, 0x589, 0x58A,
0x5BE, 0x5C0, 0x5C3, 0x5C6, 0x5F3, 0x5F4, 0x609, 0x60A, 0x60C,
0x60D, 0x61B, 0x6D4, 0x85E, 0x964, 0x965, 0x970, 0x9FD, 0xA76,
0xAF0, 0xC77, 0xC84, 0xDF4, 0xE4F, 0xE5A, 0xE5B, 0xF14, 0xF85,
0xFD9, 0xFDA, 0x10FB, 0x1400, 0x166E, 0x169B, 0x169C, 0x1735, 0x1736,
0x1944, 0x1945, 0x1A1E, 0x1A1F, 0x1B4E, 0x1B4F, 0x1C7E, 0x1C7F, 0x1CD3,
0x207D, 0x207E, 0x208D, 0x208E, 0x2329, 0x232A, 0x27C5, 0x27C6, 0x29FC,
0x29FD, 0x2CFE, 0x2CFF, 0x2D70, 0x3030, 0x303D, 0x30A0, 0x30FB, 0xA4FE,
0xA4FF, 0xA673, 0xA67E, 0xA8CE, 0xA8CF, 0xA8FC, 0xA92E, 0xA92F, 0xA95F,
0xA9DE, 0xA9DF, 0xAADE, 0xAADF, 0xAAF0, 0xAAF1, 0xABEB, 0xFD3E, 0xFD3F,
0xFE63, 0xFE68, 0xFE6A, 0xFE6B, 0xFF1A, 0xFF1B, 0xFF1F, 0xFF20, 0xFF3F,
0xFF5B, 0xFF5D
#if CHRBITS > 16
,0x1039F, 0x103D0, 0x1056F, 0x10857, 0x1091F, 0x1093F, 0x10A7F, 0x10D6E, 0x10EAD,
0x110BB, 0x110BC, 0x11174, 0x11175, 0x111CD, 0x111DB, 0x112A9, 0x113D4, 0x113D5,
0x113D7, 0x113D8, 0x1145A, 0x1145B, 0x1145D, 0x114C6, 0x116B9, 0x1183B, 0x119E2,
0x11BE1, 0x11C70, 0x11C71, 0x11EF7, 0x11EF8, 0x11FFF, 0x12FF1, 0x12FF2, 0x16A6E,
0x16A6F, 0x16AF5, 0x16B44, 0x16FE2, 0x1BC9F, 0x1E5FF, 0x1E95E, 0x1E95F
#endif
};
#define NUM_PUNCT_CHAR ((int)(sizeof(punctCharTable)/sizeof(chr)))
/*
* Unicode: white space characters.
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
{0x1F90, 0x1F97}, {0x1FA0, 0x1FA7}, {0x1FB0, 0x1FB4}, {0x1FC2, 0x1FC4},
{0x1FD0, 0x1FD3}, {0x1FE0, 0x1FE7}, {0x1FF2, 0x1FF4}, {0x2146, 0x2149},
{0x2C30, 0x2C5F}, {0x2C76, 0x2C7B}, {0x2D00, 0x2D25}, {0xA72F, 0xA731},
{0xA771, 0xA778}, {0xA793, 0xA795}, {0xAB30, 0xAB5A}, {0xAB60, 0xAB68},
{0xAB70, 0xABBF}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, {0xFF41, 0xFF5A}
#if CHRBITS > 16
,{0x10428, 0x1044F}, {0x104D8, 0x104FB}, {0x10597, 0x105A1}, {0x105A3, 0x105B1},
| | | | | | | | | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
{0x1F90, 0x1F97}, {0x1FA0, 0x1FA7}, {0x1FB0, 0x1FB4}, {0x1FC2, 0x1FC4},
{0x1FD0, 0x1FD3}, {0x1FE0, 0x1FE7}, {0x1FF2, 0x1FF4}, {0x2146, 0x2149},
{0x2C30, 0x2C5F}, {0x2C76, 0x2C7B}, {0x2D00, 0x2D25}, {0xA72F, 0xA731},
{0xA771, 0xA778}, {0xA793, 0xA795}, {0xAB30, 0xAB5A}, {0xAB60, 0xAB68},
{0xAB70, 0xABBF}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, {0xFF41, 0xFF5A}
#if CHRBITS > 16
,{0x10428, 0x1044F}, {0x104D8, 0x104FB}, {0x10597, 0x105A1}, {0x105A3, 0x105B1},
{0x105B3, 0x105B9}, {0x10CC0, 0x10CF2}, {0x10D70, 0x10D85}, {0x118C0, 0x118DF},
{0x16E60, 0x16E7F}, {0x1D41A, 0x1D433}, {0x1D44E, 0x1D454}, {0x1D456, 0x1D467},
{0x1D482, 0x1D49B}, {0x1D4B6, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D4CF},
{0x1D4EA, 0x1D503}, {0x1D51E, 0x1D537}, {0x1D552, 0x1D56B}, {0x1D586, 0x1D59F},
{0x1D5BA, 0x1D5D3}, {0x1D5EE, 0x1D607}, {0x1D622, 0x1D63B}, {0x1D656, 0x1D66F},
{0x1D68A, 0x1D6A5}, {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6E1}, {0x1D6FC, 0x1D714},
{0x1D716, 0x1D71B}, {0x1D736, 0x1D74E}, {0x1D750, 0x1D755}, {0x1D770, 0x1D788},
{0x1D78A, 0x1D78F}, {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7C9}, {0x1DF00, 0x1DF09},
{0x1DF0B, 0x1DF1E}, {0x1DF25, 0x1DF2A}, {0x1E922, 0x1E943}
#endif
};
#define NUM_LOWER_RANGE ((int)(sizeof(lowerRangeTable)/sizeof(crange)))
static const chr lowerCharTable[] = {
0xB5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10B, 0x10D, 0x10F,
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
0x4A9, 0x4AB, 0x4AD, 0x4AF, 0x4B1, 0x4B3, 0x4B5, 0x4B7, 0x4B9,
0x4BB, 0x4BD, 0x4BF, 0x4C2, 0x4C4, 0x4C6, 0x4C8, 0x4CA, 0x4CC,
0x4CE, 0x4CF, 0x4D1, 0x4D3, 0x4D5, 0x4D7, 0x4D9, 0x4DB, 0x4DD,
0x4DF, 0x4E1, 0x4E3, 0x4E5, 0x4E7, 0x4E9, 0x4EB, 0x4ED, 0x4EF,
0x4F1, 0x4F3, 0x4F5, 0x4F7, 0x4F9, 0x4FB, 0x4FD, 0x4FF, 0x501,
0x503, 0x505, 0x507, 0x509, 0x50B, 0x50D, 0x50F, 0x511, 0x513,
0x515, 0x517, 0x519, 0x51B, 0x51D, 0x51F, 0x521, 0x523, 0x525,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 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 |
0x4A9, 0x4AB, 0x4AD, 0x4AF, 0x4B1, 0x4B3, 0x4B5, 0x4B7, 0x4B9,
0x4BB, 0x4BD, 0x4BF, 0x4C2, 0x4C4, 0x4C6, 0x4C8, 0x4CA, 0x4CC,
0x4CE, 0x4CF, 0x4D1, 0x4D3, 0x4D5, 0x4D7, 0x4D9, 0x4DB, 0x4DD,
0x4DF, 0x4E1, 0x4E3, 0x4E5, 0x4E7, 0x4E9, 0x4EB, 0x4ED, 0x4EF,
0x4F1, 0x4F3, 0x4F5, 0x4F7, 0x4F9, 0x4FB, 0x4FD, 0x4FF, 0x501,
0x503, 0x505, 0x507, 0x509, 0x50B, 0x50D, 0x50F, 0x511, 0x513,
0x515, 0x517, 0x519, 0x51B, 0x51D, 0x51F, 0x521, 0x523, 0x525,
0x527, 0x529, 0x52B, 0x52D, 0x52F, 0x1C8A, 0x1E01, 0x1E03, 0x1E05,
0x1E07, 0x1E09, 0x1E0B, 0x1E0D, 0x1E0F, 0x1E11, 0x1E13, 0x1E15, 0x1E17,
0x1E19, 0x1E1B, 0x1E1D, 0x1E1F, 0x1E21, 0x1E23, 0x1E25, 0x1E27, 0x1E29,
0x1E2B, 0x1E2D, 0x1E2F, 0x1E31, 0x1E33, 0x1E35, 0x1E37, 0x1E39, 0x1E3B,
0x1E3D, 0x1E3F, 0x1E41, 0x1E43, 0x1E45, 0x1E47, 0x1E49, 0x1E4B, 0x1E4D,
0x1E4F, 0x1E51, 0x1E53, 0x1E55, 0x1E57, 0x1E59, 0x1E5B, 0x1E5D, 0x1E5F,
0x1E61, 0x1E63, 0x1E65, 0x1E67, 0x1E69, 0x1E6B, 0x1E6D, 0x1E6F, 0x1E71,
0x1E73, 0x1E75, 0x1E77, 0x1E79, 0x1E7B, 0x1E7D, 0x1E7F, 0x1E81, 0x1E83,
0x1E85, 0x1E87, 0x1E89, 0x1E8B, 0x1E8D, 0x1E8F, 0x1E91, 0x1E93, 0x1E9F,
0x1EA1, 0x1EA3, 0x1EA5, 0x1EA7, 0x1EA9, 0x1EAB, 0x1EAD, 0x1EAF, 0x1EB1,
0x1EB3, 0x1EB5, 0x1EB7, 0x1EB9, 0x1EBB, 0x1EBD, 0x1EBF, 0x1EC1, 0x1EC3,
0x1EC5, 0x1EC7, 0x1EC9, 0x1ECB, 0x1ECD, 0x1ECF, 0x1ED1, 0x1ED3, 0x1ED5,
0x1ED7, 0x1ED9, 0x1EDB, 0x1EDD, 0x1EDF, 0x1EE1, 0x1EE3, 0x1EE5, 0x1EE7,
0x1EE9, 0x1EEB, 0x1EED, 0x1EEF, 0x1EF1, 0x1EF3, 0x1EF5, 0x1EF7, 0x1EF9,
0x1EFB, 0x1EFD, 0x1FB6, 0x1FB7, 0x1FBE, 0x1FC6, 0x1FC7, 0x1FD6, 0x1FD7,
0x1FF6, 0x1FF7, 0x210A, 0x210E, 0x210F, 0x2113, 0x212F, 0x2134, 0x2139,
0x213C, 0x213D, 0x214E, 0x2184, 0x2C61, 0x2C65, 0x2C66, 0x2C68, 0x2C6A,
0x2C6C, 0x2C71, 0x2C73, 0x2C74, 0x2C81, 0x2C83, 0x2C85, 0x2C87, 0x2C89,
0x2C8B, 0x2C8D, 0x2C8F, 0x2C91, 0x2C93, 0x2C95, 0x2C97, 0x2C99, 0x2C9B,
0x2C9D, 0x2C9F, 0x2CA1, 0x2CA3, 0x2CA5, 0x2CA7, 0x2CA9, 0x2CAB, 0x2CAD,
0x2CAF, 0x2CB1, 0x2CB3, 0x2CB5, 0x2CB7, 0x2CB9, 0x2CBB, 0x2CBD, 0x2CBF,
0x2CC1, 0x2CC3, 0x2CC5, 0x2CC7, 0x2CC9, 0x2CCB, 0x2CCD, 0x2CCF, 0x2CD1,
0x2CD3, 0x2CD5, 0x2CD7, 0x2CD9, 0x2CDB, 0x2CDD, 0x2CDF, 0x2CE1, 0x2CE3,
0x2CE4, 0x2CEC, 0x2CEE, 0x2CF3, 0x2D27, 0x2D2D, 0xA641, 0xA643, 0xA645,
0xA647, 0xA649, 0xA64B, 0xA64D, 0xA64F, 0xA651, 0xA653, 0xA655, 0xA657,
0xA659, 0xA65B, 0xA65D, 0xA65F, 0xA661, 0xA663, 0xA665, 0xA667, 0xA669,
0xA66B, 0xA66D, 0xA681, 0xA683, 0xA685, 0xA687, 0xA689, 0xA68B, 0xA68D,
0xA68F, 0xA691, 0xA693, 0xA695, 0xA697, 0xA699, 0xA69B, 0xA723, 0xA725,
0xA727, 0xA729, 0xA72B, 0xA72D, 0xA733, 0xA735, 0xA737, 0xA739, 0xA73B,
0xA73D, 0xA73F, 0xA741, 0xA743, 0xA745, 0xA747, 0xA749, 0xA74B, 0xA74D,
0xA74F, 0xA751, 0xA753, 0xA755, 0xA757, 0xA759, 0xA75B, 0xA75D, 0xA75F,
0xA761, 0xA763, 0xA765, 0xA767, 0xA769, 0xA76B, 0xA76D, 0xA76F, 0xA77A,
0xA77C, 0xA77F, 0xA781, 0xA783, 0xA785, 0xA787, 0xA78C, 0xA78E, 0xA791,
0xA797, 0xA799, 0xA79B, 0xA79D, 0xA79F, 0xA7A1, 0xA7A3, 0xA7A5, 0xA7A7,
0xA7A9, 0xA7AF, 0xA7B5, 0xA7B7, 0xA7B9, 0xA7BB, 0xA7BD, 0xA7BF, 0xA7C1,
0xA7C3, 0xA7C8, 0xA7CA, 0xA7CD, 0xA7D1, 0xA7D3, 0xA7D5, 0xA7D7, 0xA7D9,
0xA7DB, 0xA7F6, 0xA7FA
#if CHRBITS > 16
,0x105BB, 0x105BC, 0x1D4BB, 0x1D7CB
#endif
};
#define NUM_LOWER_CHAR ((int)(sizeof(lowerCharTable)/sizeof(chr)))
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
{0x1F68, 0x1F6F}, {0x1FB8, 0x1FBB}, {0x1FC8, 0x1FCB}, {0x1FD8, 0x1FDB},
{0x1FE8, 0x1FEC}, {0x1FF8, 0x1FFB}, {0x210B, 0x210D}, {0x2110, 0x2112},
{0x2119, 0x211D}, {0x212A, 0x212D}, {0x2130, 0x2133}, {0x2C00, 0x2C2F},
{0x2C62, 0x2C64}, {0x2C6D, 0x2C70}, {0x2C7E, 0x2C80}, {0xA7AA, 0xA7AE},
{0xA7B0, 0xA7B4}, {0xA7C4, 0xA7C7}, {0xFF21, 0xFF3A}
#if CHRBITS > 16
,{0x10400, 0x10427}, {0x104B0, 0x104D3}, {0x10570, 0x1057A}, {0x1057C, 0x1058A},
| | | | | | | | > | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 |
{0x1F68, 0x1F6F}, {0x1FB8, 0x1FBB}, {0x1FC8, 0x1FCB}, {0x1FD8, 0x1FDB},
{0x1FE8, 0x1FEC}, {0x1FF8, 0x1FFB}, {0x210B, 0x210D}, {0x2110, 0x2112},
{0x2119, 0x211D}, {0x212A, 0x212D}, {0x2130, 0x2133}, {0x2C00, 0x2C2F},
{0x2C62, 0x2C64}, {0x2C6D, 0x2C70}, {0x2C7E, 0x2C80}, {0xA7AA, 0xA7AE},
{0xA7B0, 0xA7B4}, {0xA7C4, 0xA7C7}, {0xFF21, 0xFF3A}
#if CHRBITS > 16
,{0x10400, 0x10427}, {0x104B0, 0x104D3}, {0x10570, 0x1057A}, {0x1057C, 0x1058A},
{0x1058C, 0x10592}, {0x10C80, 0x10CB2}, {0x10D50, 0x10D65}, {0x118A0, 0x118BF},
{0x16E40, 0x16E5F}, {0x1D400, 0x1D419}, {0x1D434, 0x1D44D}, {0x1D468, 0x1D481},
{0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B5}, {0x1D4D0, 0x1D4E9}, {0x1D507, 0x1D50A},
{0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D53B, 0x1D53E}, {0x1D540, 0x1D544},
{0x1D54A, 0x1D550}, {0x1D56C, 0x1D585}, {0x1D5A0, 0x1D5B9}, {0x1D5D4, 0x1D5ED},
{0x1D608, 0x1D621}, {0x1D63C, 0x1D655}, {0x1D670, 0x1D689}, {0x1D6A8, 0x1D6C0},
{0x1D6E2, 0x1D6FA}, {0x1D71C, 0x1D734}, {0x1D756, 0x1D76E}, {0x1D790, 0x1D7A8},
{0x1E900, 0x1E921}
#endif
};
#define NUM_UPPER_RANGE ((int)(sizeof(upperRangeTable)/sizeof(crange)))
static const chr upperCharTable[] = {
0x100, 0x102, 0x104, 0x106, 0x108, 0x10A, 0x10C, 0x10E, 0x110,
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
0x4B0, 0x4B2, 0x4B4, 0x4B6, 0x4B8, 0x4BA, 0x4BC, 0x4BE, 0x4C0,
0x4C1, 0x4C3, 0x4C5, 0x4C7, 0x4C9, 0x4CB, 0x4CD, 0x4D0, 0x4D2,
0x4D4, 0x4D6, 0x4D8, 0x4DA, 0x4DC, 0x4DE, 0x4E0, 0x4E2, 0x4E4,
0x4E6, 0x4E8, 0x4EA, 0x4EC, 0x4EE, 0x4F0, 0x4F2, 0x4F4, 0x4F6,
0x4F8, 0x4FA, 0x4FC, 0x4FE, 0x500, 0x502, 0x504, 0x506, 0x508,
0x50A, 0x50C, 0x50E, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51A,
0x51C, 0x51E, 0x520, 0x522, 0x524, 0x526, 0x528, 0x52A, 0x52C,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
0x4B0, 0x4B2, 0x4B4, 0x4B6, 0x4B8, 0x4BA, 0x4BC, 0x4BE, 0x4C0,
0x4C1, 0x4C3, 0x4C5, 0x4C7, 0x4C9, 0x4CB, 0x4CD, 0x4D0, 0x4D2,
0x4D4, 0x4D6, 0x4D8, 0x4DA, 0x4DC, 0x4DE, 0x4E0, 0x4E2, 0x4E4,
0x4E6, 0x4E8, 0x4EA, 0x4EC, 0x4EE, 0x4F0, 0x4F2, 0x4F4, 0x4F6,
0x4F8, 0x4FA, 0x4FC, 0x4FE, 0x500, 0x502, 0x504, 0x506, 0x508,
0x50A, 0x50C, 0x50E, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51A,
0x51C, 0x51E, 0x520, 0x522, 0x524, 0x526, 0x528, 0x52A, 0x52C,
0x52E, 0x10C7, 0x10CD, 0x1C89, 0x1E00, 0x1E02, 0x1E04, 0x1E06, 0x1E08,
0x1E0A, 0x1E0C, 0x1E0E, 0x1E10, 0x1E12, 0x1E14, 0x1E16, 0x1E18, 0x1E1A,
0x1E1C, 0x1E1E, 0x1E20, 0x1E22, 0x1E24, 0x1E26, 0x1E28, 0x1E2A, 0x1E2C,
0x1E2E, 0x1E30, 0x1E32, 0x1E34, 0x1E36, 0x1E38, 0x1E3A, 0x1E3C, 0x1E3E,
0x1E40, 0x1E42, 0x1E44, 0x1E46, 0x1E48, 0x1E4A, 0x1E4C, 0x1E4E, 0x1E50,
0x1E52, 0x1E54, 0x1E56, 0x1E58, 0x1E5A, 0x1E5C, 0x1E5E, 0x1E60, 0x1E62,
0x1E64, 0x1E66, 0x1E68, 0x1E6A, 0x1E6C, 0x1E6E, 0x1E70, 0x1E72, 0x1E74,
0x1E76, 0x1E78, 0x1E7A, 0x1E7C, 0x1E7E, 0x1E80, 0x1E82, 0x1E84, 0x1E86,
0x1E88, 0x1E8A, 0x1E8C, 0x1E8E, 0x1E90, 0x1E92, 0x1E94, 0x1E9E, 0x1EA0,
0x1EA2, 0x1EA4, 0x1EA6, 0x1EA8, 0x1EAA, 0x1EAC, 0x1EAE, 0x1EB0, 0x1EB2,
0x1EB4, 0x1EB6, 0x1EB8, 0x1EBA, 0x1EBC, 0x1EBE, 0x1EC0, 0x1EC2, 0x1EC4,
0x1EC6, 0x1EC8, 0x1ECA, 0x1ECC, 0x1ECE, 0x1ED0, 0x1ED2, 0x1ED4, 0x1ED6,
0x1ED8, 0x1EDA, 0x1EDC, 0x1EDE, 0x1EE0, 0x1EE2, 0x1EE4, 0x1EE6, 0x1EE8,
0x1EEA, 0x1EEC, 0x1EEE, 0x1EF0, 0x1EF2, 0x1EF4, 0x1EF6, 0x1EF8, 0x1EFA,
0x1EFC, 0x1EFE, 0x1F59, 0x1F5B, 0x1F5D, 0x1F5F, 0x2102, 0x2107, 0x2115,
0x2124, 0x2126, 0x2128, 0x213E, 0x213F, 0x2145, 0x2183, 0x2C60, 0x2C67,
0x2C69, 0x2C6B, 0x2C72, 0x2C75, 0x2C82, 0x2C84, 0x2C86, 0x2C88, 0x2C8A,
0x2C8C, 0x2C8E, 0x2C90, 0x2C92, 0x2C94, 0x2C96, 0x2C98, 0x2C9A, 0x2C9C,
0x2C9E, 0x2CA0, 0x2CA2, 0x2CA4, 0x2CA6, 0x2CA8, 0x2CAA, 0x2CAC, 0x2CAE,
0x2CB0, 0x2CB2, 0x2CB4, 0x2CB6, 0x2CB8, 0x2CBA, 0x2CBC, 0x2CBE, 0x2CC0,
0x2CC2, 0x2CC4, 0x2CC6, 0x2CC8, 0x2CCA, 0x2CCC, 0x2CCE, 0x2CD0, 0x2CD2,
0x2CD4, 0x2CD6, 0x2CD8, 0x2CDA, 0x2CDC, 0x2CDE, 0x2CE0, 0x2CE2, 0x2CEB,
0x2CED, 0x2CF2, 0xA640, 0xA642, 0xA644, 0xA646, 0xA648, 0xA64A, 0xA64C,
0xA64E, 0xA650, 0xA652, 0xA654, 0xA656, 0xA658, 0xA65A, 0xA65C, 0xA65E,
0xA660, 0xA662, 0xA664, 0xA666, 0xA668, 0xA66A, 0xA66C, 0xA680, 0xA682,
0xA684, 0xA686, 0xA688, 0xA68A, 0xA68C, 0xA68E, 0xA690, 0xA692, 0xA694,
0xA696, 0xA698, 0xA69A, 0xA722, 0xA724, 0xA726, 0xA728, 0xA72A, 0xA72C,
0xA72E, 0xA732, 0xA734, 0xA736, 0xA738, 0xA73A, 0xA73C, 0xA73E, 0xA740,
0xA742, 0xA744, 0xA746, 0xA748, 0xA74A, 0xA74C, 0xA74E, 0xA750, 0xA752,
0xA754, 0xA756, 0xA758, 0xA75A, 0xA75C, 0xA75E, 0xA760, 0xA762, 0xA764,
0xA766, 0xA768, 0xA76A, 0xA76C, 0xA76E, 0xA779, 0xA77B, 0xA77D, 0xA77E,
0xA780, 0xA782, 0xA784, 0xA786, 0xA78B, 0xA78D, 0xA790, 0xA792, 0xA796,
0xA798, 0xA79A, 0xA79C, 0xA79E, 0xA7A0, 0xA7A2, 0xA7A4, 0xA7A6, 0xA7A8,
0xA7B6, 0xA7B8, 0xA7BA, 0xA7BC, 0xA7BE, 0xA7C0, 0xA7C2, 0xA7C9, 0xA7CB,
0xA7CC, 0xA7D0, 0xA7D6, 0xA7D8, 0xA7DA, 0xA7DC, 0xA7F5
#if CHRBITS > 16
,0x10594, 0x10595, 0x1D49C, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D504,
0x1D505, 0x1D538, 0x1D539, 0x1D546, 0x1D7CA
#endif
};
#define NUM_UPPER_CHAR ((int)(sizeof(upperCharTable)/sizeof(chr)))
/*
* Unicode: unicode print characters excluding space.
*/
static const crange graphRangeTable[] = {
{0x21, 0x7E}, {0xA1, 0xAC}, {0xAE, 0x377}, {0x37A, 0x37F},
{0x384, 0x38A}, {0x38E, 0x3A1}, {0x3A3, 0x52F}, {0x531, 0x556},
{0x559, 0x58A}, {0x58D, 0x58F}, {0x591, 0x5C7}, {0x5D0, 0x5EA},
{0x5EF, 0x5F4}, {0x606, 0x61B}, {0x61D, 0x6DC}, {0x6DE, 0x70D},
{0x710, 0x74A}, {0x74D, 0x7B1}, {0x7C0, 0x7FA}, {0x7FD, 0x82D},
{0x830, 0x83E}, {0x840, 0x85B}, {0x860, 0x86A}, {0x870, 0x88E},
{0x897, 0x8E1}, {0x8E3, 0x983}, {0x985, 0x98C}, {0x993, 0x9A8},
{0x9AA, 0x9B0}, {0x9B6, 0x9B9}, {0x9BC, 0x9C4}, {0x9CB, 0x9CE},
{0x9DF, 0x9E3}, {0x9E6, 0x9FE}, {0xA01, 0xA03}, {0xA05, 0xA0A},
{0xA13, 0xA28}, {0xA2A, 0xA30}, {0xA3E, 0xA42}, {0xA4B, 0xA4D},
{0xA59, 0xA5C}, {0xA66, 0xA76}, {0xA81, 0xA83}, {0xA85, 0xA8D},
{0xA8F, 0xA91}, {0xA93, 0xAA8}, {0xAAA, 0xAB0}, {0xAB5, 0xAB9},
{0xABC, 0xAC5}, {0xAC7, 0xAC9}, {0xACB, 0xACD}, {0xAE0, 0xAE3},
{0xAE6, 0xAF1}, {0xAF9, 0xAFF}, {0xB01, 0xB03}, {0xB05, 0xB0C},
|
| ︙ | ︙ | |||
679 680 681 682 683 684 685 |
{0x171F, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176C}, {0x176E, 0x1770},
{0x1780, 0x17DD}, {0x17E0, 0x17E9}, {0x17F0, 0x17F9}, {0x1800, 0x180D},
{0x180F, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18AA}, {0x18B0, 0x18F5},
{0x1900, 0x191E}, {0x1920, 0x192B}, {0x1930, 0x193B}, {0x1944, 0x196D},
{0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9}, {0x19D0, 0x19DA},
{0x19DE, 0x1A1B}, {0x1A1E, 0x1A5E}, {0x1A60, 0x1A7C}, {0x1A7F, 0x1A89},
{0x1A90, 0x1A99}, {0x1AA0, 0x1AAD}, {0x1AB0, 0x1ACE}, {0x1B00, 0x1B4C},
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | > | | > | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | < | | | | > | | | | | | | | | 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 |
{0x171F, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176C}, {0x176E, 0x1770},
{0x1780, 0x17DD}, {0x17E0, 0x17E9}, {0x17F0, 0x17F9}, {0x1800, 0x180D},
{0x180F, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18AA}, {0x18B0, 0x18F5},
{0x1900, 0x191E}, {0x1920, 0x192B}, {0x1930, 0x193B}, {0x1944, 0x196D},
{0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9}, {0x19D0, 0x19DA},
{0x19DE, 0x1A1B}, {0x1A1E, 0x1A5E}, {0x1A60, 0x1A7C}, {0x1A7F, 0x1A89},
{0x1A90, 0x1A99}, {0x1AA0, 0x1AAD}, {0x1AB0, 0x1ACE}, {0x1B00, 0x1B4C},
{0x1B4E, 0x1BF3}, {0x1BFC, 0x1C37}, {0x1C3B, 0x1C49}, {0x1C4D, 0x1C8A},
{0x1C90, 0x1CBA}, {0x1CBD, 0x1CC7}, {0x1CD0, 0x1CFA}, {0x1D00, 0x1F15},
{0x1F18, 0x1F1D}, {0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, {0x1F50, 0x1F57},
{0x1F5F, 0x1F7D}, {0x1F80, 0x1FB4}, {0x1FB6, 0x1FC4}, {0x1FC6, 0x1FD3},
{0x1FD6, 0x1FDB}, {0x1FDD, 0x1FEF}, {0x1FF2, 0x1FF4}, {0x1FF6, 0x1FFE},
{0x2010, 0x2027}, {0x2030, 0x205E}, {0x2074, 0x208E}, {0x2090, 0x209C},
{0x20A0, 0x20C0}, {0x20D0, 0x20F0}, {0x2100, 0x218B}, {0x2190, 0x2429},
{0x2440, 0x244A}, {0x2460, 0x2B73}, {0x2B76, 0x2B95}, {0x2B97, 0x2CF3},
{0x2CF9, 0x2D25}, {0x2D30, 0x2D67}, {0x2D7F, 0x2D96}, {0x2DA0, 0x2DA6},
{0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE}, {0x2DC0, 0x2DC6},
{0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE}, {0x2DE0, 0x2E5D},
{0x2E80, 0x2E99}, {0x2E9B, 0x2EF3}, {0x2F00, 0x2FD5}, {0x2FF0, 0x2FFF},
{0x3001, 0x303F}, {0x3041, 0x3096}, {0x3099, 0x30FF}, {0x3105, 0x312F},
{0x3131, 0x318E}, {0x3190, 0x31E5}, {0x31EF, 0x321E}, {0x3220, 0xA48C},
{0xA490, 0xA4C6}, {0xA4D0, 0xA62B}, {0xA640, 0xA6F7}, {0xA700, 0xA7CD},
{0xA7D5, 0xA7DC}, {0xA7F2, 0xA82C}, {0xA830, 0xA839}, {0xA840, 0xA877},
{0xA880, 0xA8C5}, {0xA8CE, 0xA8D9}, {0xA8E0, 0xA953}, {0xA95F, 0xA97C},
{0xA980, 0xA9CD}, {0xA9CF, 0xA9D9}, {0xA9DE, 0xA9FE}, {0xAA00, 0xAA36},
{0xAA40, 0xAA4D}, {0xAA50, 0xAA59}, {0xAA5C, 0xAAC2}, {0xAADB, 0xAAF6},
{0xAB01, 0xAB06}, {0xAB09, 0xAB0E}, {0xAB11, 0xAB16}, {0xAB20, 0xAB26},
{0xAB28, 0xAB2E}, {0xAB30, 0xAB6B}, {0xAB70, 0xABED}, {0xABF0, 0xABF9},
{0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6}, {0xD7CB, 0xD7FB}, {0xF900, 0xFA6D},
{0xFA70, 0xFAD9}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, {0xFB1D, 0xFB36},
{0xFB38, 0xFB3C}, {0xFB46, 0xFBC2}, {0xFBD3, 0xFD8F}, {0xFD92, 0xFDC7},
{0xFDF0, 0xFE19}, {0xFE20, 0xFE52}, {0xFE54, 0xFE66}, {0xFE68, 0xFE6B},
{0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF01, 0xFFBE}, {0xFFC2, 0xFFC7},
{0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7}, {0xFFDA, 0xFFDC}, {0xFFE0, 0xFFE6},
{0xFFE8, 0xFFEE}
#if CHRBITS > 16
,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D},
{0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10100, 0x10102}, {0x10107, 0x10133},
{0x10137, 0x1018E}, {0x10190, 0x1019C}, {0x101D0, 0x101FD}, {0x10280, 0x1029C},
{0x102A0, 0x102D0}, {0x102E0, 0x102FB}, {0x10300, 0x10323}, {0x1032D, 0x1034A},
{0x10350, 0x1037A}, {0x10380, 0x1039D}, {0x1039F, 0x103C3}, {0x103C8, 0x103D5},
{0x10400, 0x1049D}, {0x104A0, 0x104A9}, {0x104B0, 0x104D3}, {0x104D8, 0x104FB},
{0x10500, 0x10527}, {0x10530, 0x10563}, {0x1056F, 0x1057A}, {0x1057C, 0x1058A},
{0x1058C, 0x10592}, {0x10597, 0x105A1}, {0x105A3, 0x105B1}, {0x105B3, 0x105B9},
{0x105C0, 0x105F3}, {0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767},
{0x10780, 0x10785}, {0x10787, 0x107B0}, {0x107B2, 0x107BA}, {0x10800, 0x10805},
{0x1080A, 0x10835}, {0x1083F, 0x10855}, {0x10857, 0x1089E}, {0x108A7, 0x108AF},
{0x108E0, 0x108F2}, {0x108FB, 0x1091B}, {0x1091F, 0x10939}, {0x10980, 0x109B7},
{0x109BC, 0x109CF}, {0x109D2, 0x10A03}, {0x10A0C, 0x10A13}, {0x10A15, 0x10A17},
{0x10A19, 0x10A35}, {0x10A38, 0x10A3A}, {0x10A3F, 0x10A48}, {0x10A50, 0x10A58},
{0x10A60, 0x10A9F}, {0x10AC0, 0x10AE6}, {0x10AEB, 0x10AF6}, {0x10B00, 0x10B35},
{0x10B39, 0x10B55}, {0x10B58, 0x10B72}, {0x10B78, 0x10B91}, {0x10B99, 0x10B9C},
{0x10BA9, 0x10BAF}, {0x10C00, 0x10C48}, {0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2},
{0x10CFA, 0x10D27}, {0x10D30, 0x10D39}, {0x10D40, 0x10D65}, {0x10D69, 0x10D85},
{0x10E60, 0x10E7E}, {0x10E80, 0x10EA9}, {0x10EAB, 0x10EAD}, {0x10EC2, 0x10EC4},
{0x10EFC, 0x10F27}, {0x10F30, 0x10F59}, {0x10F70, 0x10F89}, {0x10FB0, 0x10FCB},
{0x10FE0, 0x10FF6}, {0x11000, 0x1104D}, {0x11052, 0x11075}, {0x1107F, 0x110BC},
{0x110BE, 0x110C2}, {0x110D0, 0x110E8}, {0x110F0, 0x110F9}, {0x11100, 0x11134},
{0x11136, 0x11147}, {0x11150, 0x11176}, {0x11180, 0x111DF}, {0x111E1, 0x111F4},
{0x11200, 0x11211}, {0x11213, 0x11241}, {0x11280, 0x11286}, {0x1128A, 0x1128D},
{0x1128F, 0x1129D}, {0x1129F, 0x112A9}, {0x112B0, 0x112EA}, {0x112F0, 0x112F9},
{0x11300, 0x11303}, {0x11305, 0x1130C}, {0x11313, 0x11328}, {0x1132A, 0x11330},
{0x11335, 0x11339}, {0x1133B, 0x11344}, {0x1134B, 0x1134D}, {0x1135D, 0x11363},
{0x11366, 0x1136C}, {0x11370, 0x11374}, {0x11380, 0x11389}, {0x11390, 0x113B5},
{0x113B7, 0x113C0}, {0x113C7, 0x113CA}, {0x113CC, 0x113D5}, {0x11400, 0x1145B},
{0x1145D, 0x11461}, {0x11480, 0x114C7}, {0x114D0, 0x114D9}, {0x11580, 0x115B5},
{0x115B8, 0x115DD}, {0x11600, 0x11644}, {0x11650, 0x11659}, {0x11660, 0x1166C},
{0x11680, 0x116B9}, {0x116C0, 0x116C9}, {0x116D0, 0x116E3}, {0x11700, 0x1171A},
{0x1171D, 0x1172B}, {0x11730, 0x11746}, {0x11800, 0x1183B}, {0x118A0, 0x118F2},
{0x118FF, 0x11906}, {0x1190C, 0x11913}, {0x11918, 0x11935}, {0x1193B, 0x11946},
{0x11950, 0x11959}, {0x119A0, 0x119A7}, {0x119AA, 0x119D7}, {0x119DA, 0x119E4},
{0x11A00, 0x11A47}, {0x11A50, 0x11AA2}, {0x11AB0, 0x11AF8}, {0x11B00, 0x11B09},
{0x11BC0, 0x11BE1}, {0x11BF0, 0x11BF9}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C36},
{0x11C38, 0x11C45}, {0x11C50, 0x11C6C}, {0x11C70, 0x11C8F}, {0x11C92, 0x11CA7},
{0x11CA9, 0x11CB6}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D36}, {0x11D3F, 0x11D47},
{0x11D50, 0x11D59}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D8E}, {0x11D93, 0x11D98},
{0x11DA0, 0x11DA9}, {0x11EE0, 0x11EF8}, {0x11F00, 0x11F10}, {0x11F12, 0x11F3A},
{0x11F3E, 0x11F5A}, {0x11FC0, 0x11FF1}, {0x11FFF, 0x12399}, {0x12400, 0x1246E},
{0x12470, 0x12474}, {0x12480, 0x12543}, {0x12F90, 0x12FF2}, {0x13000, 0x1342F},
{0x13440, 0x13455}, {0x13460, 0x143FA}, {0x14400, 0x14646}, {0x16100, 0x16139},
{0x16800, 0x16A38}, {0x16A40, 0x16A5E}, {0x16A60, 0x16A69}, {0x16A6E, 0x16ABE},
{0x16AC0, 0x16AC9}, {0x16AD0, 0x16AED}, {0x16AF0, 0x16AF5}, {0x16B00, 0x16B45},
{0x16B50, 0x16B59}, {0x16B5B, 0x16B61}, {0x16B63, 0x16B77}, {0x16B7D, 0x16B8F},
{0x16D40, 0x16D79}, {0x16E40, 0x16E9A}, {0x16F00, 0x16F4A}, {0x16F4F, 0x16F87},
{0x16F8F, 0x16F9F}, {0x16FE0, 0x16FE4}, {0x17000, 0x187F7}, {0x18800, 0x18CD5},
{0x18CFF, 0x18D08}, {0x1AFF0, 0x1AFF3}, {0x1AFF5, 0x1AFFB}, {0x1B000, 0x1B122},
{0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB}, {0x1BC00, 0x1BC6A},
{0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99}, {0x1BC9C, 0x1BC9F},
{0x1CC00, 0x1CCF9}, {0x1CD00, 0x1CEB3}, {0x1CF00, 0x1CF2D}, {0x1CF30, 0x1CF46},
{0x1CF50, 0x1CFC3}, {0x1D000, 0x1D0F5}, {0x1D100, 0x1D126}, {0x1D129, 0x1D172},
{0x1D17B, 0x1D1EA}, {0x1D200, 0x1D245}, {0x1D2C0, 0x1D2D3}, {0x1D2E0, 0x1D2F3},
{0x1D300, 0x1D356}, {0x1D360, 0x1D378}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C},
{0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D505},
{0x1D507, 0x1D50A}, {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D51E, 0x1D539},
{0x1D53B, 0x1D53E}, {0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, {0x1D552, 0x1D6A5},
{0x1D6A8, 0x1D7CB}, {0x1D7CE, 0x1DA8B}, {0x1DA9B, 0x1DA9F}, {0x1DAA1, 0x1DAAF},
{0x1DF00, 0x1DF1E}, {0x1DF25, 0x1DF2A}, {0x1E000, 0x1E006}, {0x1E008, 0x1E018},
{0x1E01B, 0x1E021}, {0x1E026, 0x1E02A}, {0x1E030, 0x1E06D}, {0x1E100, 0x1E12C},
{0x1E130, 0x1E13D}, {0x1E140, 0x1E149}, {0x1E290, 0x1E2AE}, {0x1E2C0, 0x1E2F9},
{0x1E4D0, 0x1E4F9}, {0x1E5D0, 0x1E5FA}, {0x1E7E0, 0x1E7E6}, {0x1E7E8, 0x1E7EB},
{0x1E7F0, 0x1E7FE}, {0x1E800, 0x1E8C4}, {0x1E8C7, 0x1E8D6}, {0x1E900, 0x1E94B},
{0x1E950, 0x1E959}, {0x1EC71, 0x1ECB4}, {0x1ED01, 0x1ED3D}, {0x1EE00, 0x1EE03},
{0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32}, {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F},
{0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72}, {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C},
{0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B}, {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9},
{0x1EEAB, 0x1EEBB}, {0x1F000, 0x1F02B}, {0x1F030, 0x1F093}, {0x1F0A0, 0x1F0AE},
{0x1F0B1, 0x1F0BF}, {0x1F0C1, 0x1F0CF}, {0x1F0D1, 0x1F0F5}, {0x1F100, 0x1F1AD},
{0x1F1E6, 0x1F202}, {0x1F210, 0x1F23B}, {0x1F240, 0x1F248}, {0x1F260, 0x1F265},
{0x1F300, 0x1F6D7}, {0x1F6DC, 0x1F6EC}, {0x1F6F0, 0x1F6FC}, {0x1F700, 0x1F776},
{0x1F77B, 0x1F7D9}, {0x1F7E0, 0x1F7EB}, {0x1F800, 0x1F80B}, {0x1F810, 0x1F847},
{0x1F850, 0x1F859}, {0x1F860, 0x1F887}, {0x1F890, 0x1F8AD}, {0x1F8B0, 0x1F8BB},
{0x1F900, 0x1FA53}, {0x1FA60, 0x1FA6D}, {0x1FA70, 0x1FA7C}, {0x1FA80, 0x1FA89},
{0x1FA8F, 0x1FAC6}, {0x1FACE, 0x1FADC}, {0x1FADF, 0x1FAE9}, {0x1FAF0, 0x1FAF8},
{0x1FB00, 0x1FB92}, {0x1FB94, 0x1FBF9}, {0x20000, 0x2A6DF}, {0x2A700, 0x2B739},
{0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, {0x2EBF0, 0x2EE5D},
{0x2F800, 0x2FA1D}, {0x30000, 0x3134A}, {0x31350, 0x323AF}, {0xE0100, 0xE01EF}
#endif
};
#define NUM_GRAPH_RANGE ((int)(sizeof(graphRangeTable)/sizeof(crange)))
static const chr graphCharTable[] = {
0x38C, 0x85E, 0x98F, 0x990, 0x9B2, 0x9C7, 0x9C8, 0x9D7, 0x9DC,
0x9DD, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, 0xA38, 0xA39,
0xA3C, 0xA47, 0xA48, 0xA51, 0xA5E, 0xAB2, 0xAB3, 0xAD0, 0xB0F,
0xB10, 0xB32, 0xB33, 0xB47, 0xB48, 0xB5C, 0xB5D, 0xB82, 0xB83,
0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0, 0xBD7,
0xC55, 0xC56, 0xC5D, 0xCD5, 0xCD6, 0xCDD, 0xCDE, 0xDBD, 0xDCA,
0xDD6, 0xE81, 0xE82, 0xE84, 0xEA5, 0xEC6, 0x10C7, 0x10CD, 0x1258,
0x12C0, 0x1772, 0x1773, 0x1940, 0x1F59, 0x1F5B, 0x1F5D, 0x2070, 0x2071,
0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xA7D0, 0xA7D1, 0xA7D3, 0xFB3E, 0xFB40,
0xFB41, 0xFB43, 0xFB44, 0xFDCF, 0xFFFC, 0xFFFD
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x101A0, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837,
0x10838, 0x1083C, 0x108F4, 0x108F5, 0x1093F, 0x10A05, 0x10A06, 0x10D8E, 0x10D8F,
0x10EB0, 0x10EB1, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x11347, 0x11348,
0x11350, 0x11357, 0x1138B, 0x1138E, 0x113C2, 0x113C5, 0x113D7, 0x113D8, 0x113E1,
0x113E2, 0x11909, 0x11915, 0x11916, 0x11937, 0x11938, 0x11D08, 0x11D09, 0x11D3A,
0x11D3C, 0x11D3D, 0x11D67, 0x11D68, 0x11D90, 0x11D91, 0x11FB0, 0x16FF0, 0x16FF1,
0x1AFFD, 0x1AFFE, 0x1B132, 0x1B155, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6,
0x1D4BB, 0x1D546, 0x1E023, 0x1E024, 0x1E08F, 0x1E14E, 0x1E14F, 0x1E2FF, 0x1E5FF,
0x1E7ED, 0x1E7EE, 0x1E95E, 0x1E95F, 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39,
0x1EE3B, 0x1EE42, 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57,
0x1EE59, 0x1EE5B, 0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E, 0x1EEF0,
0x1EEF1, 0x1F250, 0x1F251, 0x1F7F0, 0x1F8C0, 0x1F8C1
#endif
};
#define NUM_GRAPH_CHAR ((int)(sizeof(graphCharTable)/sizeof(chr)))
/*
* End of auto-generated Unicode character ranges declarations.
|
| ︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 |
break;
case CC_BLANK:
cv = getcvec(v, 2, 0);
addchr(cv, '\t');
addchr(cv, ' ');
break;
case CC_CNTRL:
| | < | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
break;
case CC_BLANK:
cv = getcvec(v, 2, 0);
addchr(cv, '\t');
addchr(cv, ' ');
break;
case CC_CNTRL:
cv = getcvec(v, NUM_CONTROL_CHAR, NUM_CONTROL_RANGE);
if (cv) {
for (i=0 ; i<NUM_CONTROL_RANGE ; i++) {
addrange(cv, controlRangeTable[i].start,
controlRangeTable[i].end);
}
for (i=0 ; i<NUM_CONTROL_CHAR ; i++) {
addchr(cv, controlCharTable[i]);
}
|
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
}
for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
addchr(cv, upperCharTable[i]);
}
}
break;
case CC_PRINT:
| | | | | | | | | | | | | | | | | | | | 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 |
}
for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
addchr(cv, upperCharTable[i]);
}
}
break;
case CC_PRINT:
cv = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE - 1);
if (cv) {
for (i=1 ; i<NUM_SPACE_RANGE ; i++) {
addrange(cv, spaceRangeTable[i].start,
spaceRangeTable[i].end);
}
for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
addchr(cv, spaceCharTable[i]);
}
for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
addrange(cv, graphRangeTable[i].start,
graphRangeTable[i].end);
}
for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
addchr(cv, graphCharTable[i]);
}
}
break;
case CC_GRAPH:
cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE);
if (cv) {
for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
addrange(cv, graphRangeTable[i].start,
graphRangeTable[i].end);
}
|
| ︙ | ︙ |
Changes to generic/regc_nfa.c.
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
}
return NULL;
}
/*
- cparc - allocate a new arc within an NFA, copying details from old one
^ static void cparc(struct nfa *, struct arc *, struct state *,
| | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
}
return NULL;
}
/*
- cparc - allocate a new arc within an NFA, copying details from old one
^ static void cparc(struct nfa *, struct arc *, struct state *,
^ struct state *);
*/
static void
cparc(
struct nfa *nfa,
struct arc *oa,
struct state *from,
struct state *to)
|
| ︙ | ︙ | |||
637 638 639 640 641 642 643 |
const struct arc *bb = *((const struct arc * const *) b);
/* we check the fields in the order they are most likely to be different */
if (aa->from->no < bb->from->no) {
return -1;
}
if (aa->from->no > bb->from->no) {
| | | | | | | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
const struct arc *bb = *((const struct arc * const *) b);
/* we check the fields in the order they are most likely to be different */
if (aa->from->no < bb->from->no) {
return -1;
}
if (aa->from->no > bb->from->no) {
return 1;
}
if (aa->co < bb->co) {
return -1;
}
if (aa->co > bb->co) {
return 1;
}
if (aa->type < bb->type) {
return -1;
}
if (aa->type > bb->type) {
return 1;
}
return 0;
}
/*
* sortouts - sort the out arcs of a state by to/color/type
*/
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 |
/* With not too many arcs, just do them one at a time */
struct arc *a;
for (a = oldState->outs; a != NULL; a = a->outchain) {
cparc(nfa, a, newState, a->to);
}
} else {
| | | 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 |
/* With not too many arcs, just do them one at a time */
struct arc *a;
for (a = oldState->outs; a != NULL; a = a->outchain) {
cparc(nfa, a, newState, a->to);
}
} else {
/*
* With many arcs, use a sort-merge approach. Note that createarc()
* will put new arcs onto the front of newState's chain, so it does
* not break our walk through the sorted part of the chain.
*/
struct arc *oa;
struct arc *na;
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
}
}
}
/*
- cloneouts - copy out arcs of a state to another state pair, modifying type
^ static void cloneouts(struct nfa *, struct state *, struct state *,
| | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
}
}
}
/*
- cloneouts - copy out arcs of a state to another state pair, modifying type
^ static void cloneouts(struct nfa *, struct state *, struct state *,
^ struct state *, int);
*/
static void
cloneouts(
struct nfa *nfa,
struct state *old,
struct state *from,
struct state *to,
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 | /* - dupnfa - duplicate sub-NFA * Another recursive traversal, this time using tmp to point to duplicates as * well as mark already-seen states. (You knew there was a reason why it's a * state pointer, didn't you? :-)) ^ static void dupnfa(struct nfa *, struct state *, struct state *, | | | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
/*
- dupnfa - duplicate sub-NFA
* Another recursive traversal, this time using tmp to point to duplicates as
* well as mark already-seen states. (You knew there was a reason why it's a
* state pointer, didn't you? :-))
^ static void dupnfa(struct nfa *, struct state *, struct state *,
^ struct state *, struct state *);
*/
static void
dupnfa(
struct nfa *nfa,
struct state *start, /* duplicate of subNFA starting here */
struct state *stop, /* and stopping here */
struct state *from, /* stringing duplicate from here */
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 |
s = newstate(nfa);
if (NISERR()) {
return 0;
}
s->tmp = *intermediates;
*intermediates = s;
}
| | | | | 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 |
s = newstate(nfa);
if (NISERR()) {
return 0;
}
s->tmp = *intermediates;
*intermediates = s;
}
cparc(nfa, con, a->from, s);
cparc(nfa, a, s, to);
freearc(nfa, a);
break;
default:
assert(NOTREACHED);
break;
}
}
/*
|
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 |
if (NISERR()) {
return 0;
}
s->tmp = *intermediates;
*intermediates = s;
}
cparc(nfa, con, s, a->to);
| | | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 |
if (NISERR()) {
return 0;
}
s->tmp = *intermediates;
*intermediates = s;
}
cparc(nfa, con, s, a->to);
cparc(nfa, a, from, s);
freearc(nfa, a);
break;
default:
assert(NOTREACHED);
break;
}
}
/*
|
| ︙ | ︙ | |||
2017 2018 2019 2020 2021 2022 2023 |
/* Add s2's original inarcs to arcarray[], but ignore empties */
for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) {
if (a->type != EMPTY) {
arcarray[arccount++] = a;
}
}
| | | | | | | 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 |
/* Add s2's original inarcs to arcarray[], but ignore empties */
for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) {
if (a->type != EMPTY) {
arcarray[arccount++] = a;
}
}
/* Reset the tmp fields as we walk back */
nexts = s2->tmp;
s2->tmp = NULL;
}
s->tmp = NULL;
assert(arccount <= totalinarcs);
/* Remember how many original inarcs this state has */
prevnins = s->nins;
/* Add non-duplicate inarcs to target state */
mergeins(nfa, s, arcarray, arccount);
|
| ︙ | ︙ | |||
2181 2182 2183 2184 2185 2186 2187 |
for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
nexta = a->outchain;
if (isconstraintarc(a)) {
if (a->to == s) {
freearc(nfa, a);
} else {
hasconstraints = 1;
| | | | | | 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 |
for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
nexta = a->outchain;
if (isconstraintarc(a)) {
if (a->to == s) {
freearc(nfa, a);
} else {
hasconstraints = 1;
}
}
}
/* If we removed all the outarcs, the state is useless. */
if (s->nouts == 0 && !s->flag) {
dropstate(nfa, s);
}
}
/* Nothing to do if no remaining constraint arcs */
if (NISERR() || !hasconstraints) {
return;
}
|
| ︙ | ︙ | |||
2231 2232 2233 2234 2235 2236 2237 |
s->tmp = NULL;
if ((s->nins == 0 || s->nouts == 0) && !s->flag) {
dropstate(nfa, s);
}
}
if (f != NULL) {
| | | 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 |
s->tmp = NULL;
if ((s->nins == 0 || s->nouts == 0) && !s->flag) {
dropstate(nfa, s);
}
}
if (f != NULL) {
dumpnfa(nfa, f);
}
}
/*
* findconstraintloop - recursively find a loop of constraint arcs
*
* If we find a loop, break it by calling breakconstraintloop(), then
|
| ︙ | ︙ | |||
2721 2722 2723 2724 2725 2726 2727 |
}
nfa->nstates = n;
}
/*
- markreachable - recursive marking of reachable states
^ static void markreachable(struct nfa *, struct state *, struct state *,
| | | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 |
}
nfa->nstates = n;
}
/*
- markreachable - recursive marking of reachable states
^ static void markreachable(struct nfa *, struct state *, struct state *,
^ struct state *);
*/
static void
markreachable(
struct nfa *nfa,
struct state *s,
struct state *okay, /* consider only states with this mark */
struct state *mark) /* the value to mark with */
|
| ︙ | ︙ | |||
2745 2746 2747 2748 2749 2750 2751 |
markreachable(nfa, a->to, okay, mark);
}
}
/*
- markcanreach - recursive marking of states which can reach here
^ static void markcanreach(struct nfa *, struct state *, struct state *,
| | | 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 |
markreachable(nfa, a->to, okay, mark);
}
}
/*
- markcanreach - recursive marking of states which can reach here
^ static void markcanreach(struct nfa *, struct state *, struct state *,
^ struct state *);
*/
static void
markcanreach(
struct nfa *nfa,
struct state *s,
struct state *okay, /* consider only states with this mark */
struct state *mark) /* the value to mark with */
|
| ︙ | ︙ |
Changes to generic/regcomp.c.
| ︙ | ︙ | |||
640 641 642 643 644 645 646 | /* - parse - parse an RE * This is actually just the top level, which parses a bunch of branches tied * together with '|'. They appear in the tree as the left children of a chain * of '|' subres. ^ static struct subre *parse(struct vars *, int, int, struct state *, | | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
/*
- parse - parse an RE
* This is actually just the top level, which parses a bunch of branches tied
* together with '|'. They appear in the tree as the left children of a chain
* of '|' subres.
^ static struct subre *parse(struct vars *, int, int, struct state *,
^ struct state *);
*/
static struct subre *
parse(
struct vars *v,
int stopper, /* EOS or ')' */
int type, /* LACON (lookahead subRE) or PLAIN */
struct state *init, /* initial state */
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | /* - parsebranch - parse one branch of an RE * This mostly manages concatenation, working closely with parseqatom(). * Concatenated things are bundled up as much as possible, with separate * ',' nodes introduced only when necessary due to substructure. ^ static struct subre *parsebranch(struct vars *, int, int, struct state *, | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
/*
- parsebranch - parse one branch of an RE
* This mostly manages concatenation, working closely with parseqatom().
* Concatenated things are bundled up as much as possible, with separate
* ',' nodes introduced only when necessary due to substructure.
^ static struct subre *parsebranch(struct vars *, int, int, struct state *,
^ struct state *, int);
*/
static struct subre *
parsebranch(
struct vars *v,
int stopper, /* EOS or ')' */
int type, /* LACON (lookahead subRE) or PLAIN */
struct state *left, /* leftmost state */
|
| ︙ | ︙ | |||
771 772 773 774 775 776 777 | /* - parseqatom - parse one quantified atom or constraint of an RE * The bookkeeping near the end cooperates very closely with parsebranch(); in * particular, it contains a recursion that can involve parsing the rest of * the branch, making this function's name somewhat inaccurate. ^ static void parseqatom(struct vars *, int, int, struct state *, | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 |
/*
- parseqatom - parse one quantified atom or constraint of an RE
* The bookkeeping near the end cooperates very closely with parsebranch(); in
* particular, it contains a recursion that can involve parsing the rest of
* the branch, making this function's name somewhat inaccurate.
^ static void parseqatom(struct vars *, int, int, struct state *,
^ struct state *, struct subre *);
*/
static void
parseqatom(
struct vars *v,
int stopper, /* EOS or ')' */
int type, /* LACON (lookahead subRE) or PLAIN */
struct state *lp, /* left state to hang it on */
|
| ︙ | ︙ | |||
1645 1646 1647 1648 1649 1650 1651 |
dovec(v, allcases(v, c), lp, rp);
}
/*
- dovec - fill in arcs for each element of a cvec
^ static void dovec(struct vars *, struct cvec *, struct state *,
| | | 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 |
dovec(v, allcases(v, c), lp, rp);
}
/*
- dovec - fill in arcs for each element of a cvec
^ static void dovec(struct vars *, struct cvec *, struct state *,
^ struct state *);
*/
static void
dovec(
struct vars *v,
struct cvec *cv,
struct state *lp,
struct state *rp)
|
| ︙ | ︙ |
Changes to generic/rege_dfa.c.
| ︙ | ︙ | |||
155 156 157 158 159 160 161 |
return NULL;
}
/*
- shortest - shortest-preferred matching engine
^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *,
| | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
return NULL;
}
/*
- shortest - shortest-preferred matching engine
^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *,
^ chr **, int *);
*/
static chr * /* endpoint, or NULL */
shortest(
struct vars *const v,
struct dfa *const d,
chr *const start, /* where the match should start */
chr *const min, /* match must end at or after here */
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
}
return nopr;
}
/*
- newDFA - set up a fresh DFA
^ static struct dfa *newDFA(struct vars *, struct cnfa *,
| | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
}
return nopr;
}
/*
- newDFA - set up a fresh DFA
^ static struct dfa *newDFA(struct vars *, struct cnfa *,
^ struct colormap *, struct smalldfa *);
*/
static struct dfa *
newDFA(
struct vars *const v,
struct cnfa *const cnfa,
struct colormap *const cm,
struct smalldfa *sml) /* preallocated space, may be NULL */
|
| ︙ | ︙ | |||
473 474 475 476 477 478 479 |
d->lastnopr = NULL;
return ss;
}
/*
- miss - handle a cache miss
^ static struct sset *miss(struct vars *, struct dfa *, struct sset *,
| | | 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 |
d->lastnopr = NULL;
return ss;
}
/*
- miss - handle a cache miss
^ static struct sset *miss(struct vars *, struct dfa *, struct sset *,
^ pcolor, chr *, chr *);
*/
static struct sset * /* NULL if goes to empty set */
miss(
struct vars *const v, /* used only for debug flags */
struct dfa *const d,
struct sset *const css,
const pcolor co,
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
}
}
/*
* Nobody's old enough?!? -- something's really wrong.
*/
| | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
}
}
/*
* Nobody's old enough?!? -- something's really wrong.
*/
FDEBUG(("cannot find victim to replace!\n"));
assert(NOTREACHED);
ERR(REG_ASSERT);
return d->ssets;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/regerrs.h.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
{ REG_OKAY, "REG_OKAY", "no errors detected" },
{ REG_NOMATCH, "REG_NOMATCH", "failed to match" },
{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.8)" },
{ REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" },
{ REG_ECTYPE, "REG_ECTYPE", "invalid character class" },
{ REG_EESCAPE, "REG_EESCAPE", "invalid escape \\ sequence" },
{ REG_ESUBREG, "REG_ESUBREG", "invalid backreference number" },
{ REG_EBRACK, "REG_EBRACK", "brackets [] not balanced" },
{ REG_EPAREN, "REG_EPAREN", "parentheses () not balanced" },
{ REG_EBRACE, "REG_EBRACE", "braces {} not balanced" },
{ REG_BADBR, "REG_BADBR", "invalid repetition count(s)" },
{ REG_ERANGE, "REG_ERANGE", "invalid character range" },
{ REG_ESPACE, "REG_ESPACE", "out of memory" },
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
{ REG_OKAY, "REG_OKAY", "no errors detected" },
{ REG_NOMATCH, "REG_NOMATCH", "failed to match" },
{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.8)" },
{ REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" },
{ REG_ECTYPE, "REG_ECTYPE", "invalid character class" },
{ REG_EESCAPE, "REG_EESCAPE", "invalid escape \\ sequence" },
{ REG_ESUBREG, "REG_ESUBREG", "invalid backreference number" },
{ REG_EBRACK, "REG_EBRACK", "brackets [] not balanced" },
{ REG_EPAREN, "REG_EPAREN", "parentheses () not balanced" },
{ REG_EBRACE, "REG_EBRACE", "braces {} not balanced" },
{ REG_BADBR, "REG_BADBR", "invalid repetition count(s)" },
{ REG_ERANGE, "REG_ERANGE", "invalid character range" },
{ REG_ESPACE, "REG_ESPACE", "out of memory" },
{ REG_BADRPT, "REG_BADRPT", "invalid quantifier operand" },
{ REG_ASSERT, "REG_ASSERT", "\"cannot happen\" -- you found a bug" },
{ REG_INVARG, "REG_INVARG", "invalid argument to regex function" },
{ REG_MIXED, "REG_MIXED", "character widths of regex and string differ" },
{ REG_BADOPT, "REG_BADOPT", "invalid embedded option" },
{ REG_ETOOBIG, "REG_ETOOBIG", "regular expression is too complex" },
{ REG_ECOLORS, "REG_ECOLORS", "too many colors" },
|
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
}
declare 20 {
void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
| < < < < < < < < | 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 |
}
declare 20 {
void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
declare 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes,
Tcl_Size numBytes, const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv,
const char *file, int line)
}
declare 27 {
Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
declare 28 {
Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, Tcl_Size length,
const char *file, int line)
}
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
| < < < < < | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 38 {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 {
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
void *lengthPtr)
}
declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first,
Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[])
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
void *lengthPtr)
}
declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first,
Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 50 {
Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes)
}
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
declare 53 {
Tcl_Obj *Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 55 {
Tcl_Obj *Tcl_NewObj(void)
}
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length)
}
declare 58 {
unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes)
}
declare 59 {
void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
Tcl_Size numBytes)
}
declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
declare 62 {
void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 64 {
void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
}
declare 65 {
void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
}
declare 68 {
void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 {
void Tcl_AppendElement(Tcl_Interp *interp, const char *element)
}
declare 70 {
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 |
}
declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
declare 75 {
int Tcl_AsyncReady(void)
}
| < < < < < < < < | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
}
declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
declare 75 {
int Tcl_AsyncReady(void)
}
declare 78 {
int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName,
const char *optionList)
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
void *clientData)
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
}
declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
| < < < < < < | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
}
declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
|
| ︙ | ︙ | |||
478 479 480 481 482 483 484 |
}
declare 127 {
const char *Tcl_ErrnoId(void)
}
declare 128 {
const char *Tcl_ErrnoMsg(int err)
}
| < < < < < < < < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
}
declare 127 {
const char *Tcl_ErrnoId(void)
}
declare 128 {
const char *Tcl_ErrnoMsg(int err)
}
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
declare 132 {
void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
TCL_NORETURN void Tcl_Exit(int status)
}
declare 134 {
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
| < < < < < < < < < < < < < | | | 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 |
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
declare 149 {
int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 150 {
void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
declare 151 {
Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName,
|
| ︙ | ︙ | |||
637 638 639 640 641 642 643 |
}
declare 172 {
Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
| < < < < < < < < < < < < < < < < < | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
}
declare 172 {
Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 176 {
const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 179 {
int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName,
const char *hiddenCmdToken)
}
declare 180 {
int Tcl_Init(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
# declare 188 {
# Tcl_MainLoop
# }
declare 189 {
Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode)
}
| < < < < | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
# declare 188 {
# Tcl_MainLoop
# }
declare 189 {
Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode)
}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
char *Tcl_Merge(Tcl_Size argc, const char *const *argv)
}
declare 193 {
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
}
declare 218 {
Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr)
}
| < < < < | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
}
declare 218 {
Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr)
}
declare 221 {
int Tcl_ServiceAll(void)
}
declare 222 {
int Tcl_ServiceEvent(int flags)
}
declare 223 {
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
| < < < < < < < < < < < < < < | 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 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
declare 231 {
Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth)
}
declare 233 {
int Tcl_SetServiceMode(int mode)
}
declare 234 {
void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
}
declare 235 {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 238 {
const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
const char *Tcl_SignalId(int sig)
}
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr)
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr)
}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, void *clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
declare 250 {
Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, Tcl_Size len, int atHead)
}
declare 251 {
void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
}
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
void *clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
declare 259 {
int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1,
const char *part2, const char *localName, int flags)
}
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 262 {
void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
void *prevClientData)
}
declare 263 {
Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, Tcl_Size slen)
}
declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
int Tcl_DumpActiveMemory(const char *fileName)
}
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr)
}
declare 272 {
const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
declare 279 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
declare 280 {
void Tcl_InitMemory(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 |
}
# 284 was reserved, but added in 8.4a2
declare 284 {
void Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
}
| < | > | > > < < < < | 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 |
}
# 284 was reserved, but added in 8.4a2
declare 284 {
void Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
}
declare 285 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
Tcl_Size *objcPtr, Tcl_Obj ***objvPtr)
}
# Added in 8.1:
declare 286 {
void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
}
declare 287 {
Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
declare 288 {
void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes,
int flags)
}
declare 292 {
int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[],
int flags)
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 |
declare 312 {
Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length)
}
declare 313 {
Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
Tcl_Size charsToRead, int appendFlag)
}
| < < < < < < < < | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
declare 312 {
Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length)
}
declare 313 {
Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
Tcl_Size charsToRead, int appendFlag)
}
declare 316 {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name)
}
declare 317 {
Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
}
declare 339 {
Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
| < < < < < < < < | 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
}
declare 339 {
Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
declare 343 {
void Tcl_AlertNotifier(void *clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
}
declare 345 {
|
| ︙ | ︙ | |||
1293 1294 1295 1296 1297 1298 1299 |
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
Tcl_Size Tcl_Char16Len(const unsigned short *uniStr)
}
| < < < < < < < < < < | 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 |
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
Tcl_Size Tcl_Char16Len(const unsigned short *uniStr)
}
declare 354 {
char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
Tcl_Size uniLength, Tcl_DString *dsPtr)
}
declare 355 {
unsigned short *Tcl_UtfToChar16DString(const char *src,
Tcl_Size length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
const char *command, Tcl_Size length)
}
|
| ︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 |
}
declare 380 {
Tcl_Size TclGetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
}
| < < < < | 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 |
}
declare 380 {
Tcl_Size TclGetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
}
declare 383 {
Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
}
declare 384 {
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
Tcl_Size length)
}
|
| ︙ | ︙ | |||
1465 1466 1467 1468 1469 1470 1471 |
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
| < < < < < < < < < < | 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 |
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 402 {
Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc(
const Tcl_ChannelType *chanTypePtr)
}
declare 403 {
Tcl_DriverInputProc *Tcl_ChannelInputProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 406 {
Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 407 {
Tcl_DriverGetOptionProc *Tcl_ChannelGetOptionProc(
const Tcl_ChannelType *chanTypePtr)
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
}
declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
| < < < < < < < < < < < < < < < < < < < | 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 |
}
declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
declare 423 {
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
const Tcl_HashKeyType *typePtr)
}
declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
|
| ︙ | ︙ | |||
1600 1601 1602 1603 1604 1605 1606 |
}
# introduced in 8.4a3
declare 434 {
Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, void *lengthPtr)
}
| < < < < < < < < < < < < | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
}
# introduced in 8.4a3
declare 434 {
Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, void *lengthPtr)
}
# TIP#36 (better access to 'subst') dkf
declare 437 {
Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
# TIP#17 (virtual filesystem layer) vdarley
declare 438 {
|
| ︙ | ︙ | |||
1925 1926 1927 1928 1929 1930 1931 |
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
const char *encodingName)
}
| < < < < < | 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 |
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
const char *encodingName)
}
# TIP#143 (resource limits) dkf
declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
declare 521 {
|
| ︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 |
}
declare 655 {
const char *Tcl_UtfNext(const char *src)
}
declare 656 {
const char *Tcl_UtfPrev(const char *src, const char *start)
}
| < | > | | < > > | | | | | 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 |
}
declare 655 {
const char *Tcl_UtfNext(const char *src)
}
declare 656 {
const char *Tcl_UtfPrev(const char *src, const char *start)
}
# TIP 701
declare 657 {
int Tcl_FSTildeExpand(Tcl_Interp *interp, const char *path,
Tcl_DString *dsPtr)
}
# TIP 656
declare 658 {
int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr,
Tcl_Size *errorLocationPtr)
}
declare 659 {
int Tcl_UtfToExternalDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr,
Tcl_Size *errorLocationPtr)
}
# TIP #511
declare 660 {
int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber)
}
|
| ︙ | ︙ | |||
2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 |
declare 686 {
int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n)
}
declare 687 {
int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n)
}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
| > > > > > > > > | | 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 |
declare 686 {
int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n)
}
declare 687 {
int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n)
}
# TIP #648
declare 688 {
Tcl_Obj *Tcl_NewWideUIntObj(Tcl_WideUInt wideValue)
}
declare 689 {
void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, Tcl_WideUInt uwideValue)
}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
declare 690 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
|
| ︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 |
}
##############################################################################
# Public functions that are not accessible via the stubs table.
export {
| | | | | | 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 |
}
##############################################################################
# Public functions that are not accessible via the stubs table.
export {
TCL_NORETURN void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc,
Tcl_Interp *interp)
}
export {
void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix,
Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
}
export {
const char *Tcl_SetPanicProc(Tcl_PanicProc *panicProc)
}
export {
Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc)
}
export {
const char *Tcl_FindExecutable(const char *argv0)
}
export {
const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact)
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | * update the version numbers: * * library/init.tcl (1 LOC patch) * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README.md (sections 0 and 2, with and without separator) | < | | | | | | | 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 | * update the version numbers: * * library/init.tcl (1 LOC patch) * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README.md (sections 0 and 2, with and without separator) * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) */ #if !defined(TCL_MAJOR_VERSION) # define TCL_MAJOR_VERSION 9 #endif #if TCL_MAJOR_VERSION == 9 # define TCL_MINOR_VERSION 0 # define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE # define TCL_RELEASE_SERIAL 2 # define TCL_VERSION "9.0" # define TCL_PATCH_LEVEL "9.0.2" #endif /* TCL_MAJOR_VERSION */ #if defined(RC_INVOKED) /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. */ |
| ︙ | ︙ | |||
86 87 88 89 90 91 92 | #ifndef RC_INVOKED /* * Special macro to define mutexes. */ | | > | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
#ifndef RC_INVOKED
/*
* Special macro to define mutexes.
*/
#define TCL_DECLARE_MUTEX(name) \
static Tcl_Mutex name;
/*
* Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and
* SEEK_END, all #define'd by stdio.h .
*
* Also, many extensions need stdio.h, and they've grown accustomed to tcl.h
* providing it for them rather than #include-ing it themselves as they
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 | # endif # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) # define TCL_NORETURN1 __attribute__ ((noreturn)) #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | # endif # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) # define TCL_NORETURN1 __attribute__ ((noreturn)) #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) # define TCL_NORETURN __declspec(noreturn) # define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ # define TCL_NOINLINE /* nothing */ # endif # define TCL_NORETURN1 /* nothing */ #endif |
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
#if TCL_MAJOR_VERSION < 9
typedef int Tcl_Size;
# define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1))
# define TCL_SIZE_MODIFIER ""
#else
typedef ptrdiff_t Tcl_Size;
| | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
#if TCL_MAJOR_VERSION < 9
typedef int Tcl_Size;
# define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1))
# define TCL_SIZE_MODIFIER ""
#else
typedef ptrdiff_t Tcl_Size;
# define TCL_SIZE_MAX ((Tcl_Size)(((size_t)-1)>>1))
# define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#endif /* TCL_MAJOR_VERSION */
#ifdef _WIN32
# if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T)
typedef struct __stat64 Tcl_StatBuf;
# elif defined(_USE_32BIT_TIME_T)
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | #define TCL_REG_CANMATCH 001000 /* Report details on partial/limited * matches. */ /* * Flags values passed to Tcl_RegExpExecObj. */ | | | | | | | 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 |
#define TCL_REG_CANMATCH 001000 /* Report details on partial/limited
* matches. */
/*
* Flags values passed to Tcl_RegExpExecObj.
*/
#define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */
#define TCL_REG_NOTEOL 0002 /* End of string does not match $. */
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
#if TCL_MAJOR_VERSION > 8
Tcl_Size start; /* Character offset of first character in
* match. */
Tcl_Size end; /* Character offset of first character after
* the match. */
#else
long start;
long end;
#endif
} Tcl_RegExpIndices;
typedef struct Tcl_RegExpInfo {
Tcl_Size nsubs; /* Number of subexpressions in the compiled
* expression. */
Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */
#if TCL_MAJOR_VERSION > 8
Tcl_Size extendStart; /* The offset at which a subsequent match
* might begin. */
#else
long extendStart;
long reserved; /* Reserved for later use. */
#endif
} Tcl_RegExpInfo;
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 | * TCL_RETURN The command requests that the current function return; * the interpreter's result contains the function's * return value. * TCL_BREAK The command requests that the innermost loop be * exited; the interpreter's result is meaningless. * TCL_CONTINUE Go on to the next iteration of the current loop; the * interpreter's result is meaningless. */ #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ #define TCL_SUBST_COMMANDS 001 | > > > > | 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 | * TCL_RETURN The command requests that the current function return; * the interpreter's result contains the function's * return value. * TCL_BREAK The command requests that the innermost loop be * exited; the interpreter's result is meaningless. * TCL_CONTINUE Go on to the next iteration of the current loop; the * interpreter's result is meaningless. * Integer return codes in the range TCL_CODE_USER_MIN to TCL_CODE_USER_MAX are * reserved for the use of packages. */ #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 #define TCL_CODE_USER_MIN 5 #define TCL_CODE_USER_MAX 0x3fffffff /* 1073741823 */ /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ #define TCL_SUBST_COMMANDS 001 |
| ︙ | ︙ | |||
611 612 613 614 615 616 617 | void *clientData); typedef void (Tcl_DeleteFileHandlerProc) (int fd); typedef void (Tcl_AlertNotifierProc) (void *clientData); typedef void (Tcl_ServiceModeHookProc) (int mode); typedef void *(Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); | | | | | | | < | | | | | | | < | | | < | | | 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 | void *clientData); typedef void (Tcl_DeleteFileHandlerProc) (int fd); typedef void (Tcl_AlertNotifierProc) (void *clientData); typedef void (Tcl_ServiceModeHookProc) (int mode); typedef void *(Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); /* Abstract List functions */ typedef Tcl_Size (Tcl_ObjTypeLengthProc) (struct Tcl_Obj *listPtr); typedef int (Tcl_ObjTypeIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, Tcl_Size index, struct Tcl_Obj** elemObj); typedef int (Tcl_ObjTypeSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, Tcl_Size fromIdx, Tcl_Size toIdx, struct Tcl_Obj **newObjPtr); typedef int (Tcl_ObjTypeReverseProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, struct Tcl_Obj **newObjPtr); typedef int (Tcl_ObjTypeGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, Tcl_Size *objcptr, struct Tcl_Obj ***objvptr); typedef struct Tcl_Obj *(Tcl_ObjTypeSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, Tcl_Size indexCount, struct Tcl_Obj *const indexArray[], struct Tcl_Obj *valueObj); typedef int (Tcl_ObjTypeReplaceProc) (Tcl_Interp *interp, struct Tcl_Obj *listObj, Tcl_Size first, Tcl_Size numToDelete, Tcl_Size numToInsert, struct Tcl_Obj *const insertObjs[]); typedef int (Tcl_ObjTypeInOperatorProc) (Tcl_Interp *interp, struct Tcl_Obj *valueObj, struct Tcl_Obj *listObj, int *boolResult); #ifndef TCL_NO_DEPRECATED # define Tcl_PackageInitProc Tcl_LibraryInitProc # define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc #endif /* |
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
/* Called to update the string rep from the
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
#if TCL_MAJOR_VERSION > 8
| | | | | | | > | | | | | | > | | > | | | | | | | > > | 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 |
/* Called to update the string rep from the
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
#if TCL_MAJOR_VERSION > 8
size_t version; /* Version field for future-proofing. */
/* List emulation functions - ObjType Version 1 */
Tcl_ObjTypeLengthProc *lengthProc;
/* Return the [llength] of the AbstractList */
Tcl_ObjTypeIndexProc *indexProc;
/* Return a value (Tcl_Obj) at a given index */
Tcl_ObjTypeSliceProc *sliceProc;
/* Return an AbstractList for
* [lrange $al $start $end] */
Tcl_ObjTypeReverseProc *reverseProc;
/* Return an AbstractList for [lreverse $al] */
Tcl_ObjTypeGetElements *getElementsProc;
/* Return an objv[] of all elements in the list */
Tcl_ObjTypeSetElement *setElementProc;
/* Replace the element at the indicies with the
* given valueObj. */
Tcl_ObjTypeReplaceProc *replaceProc;
/* Replace sublist with another sublist */
Tcl_ObjTypeInOperatorProc *inOperProc;
/* "in" and "ni" expr list operation.
* Determine if the given string value matches
* an element in the list. */
#endif
} Tcl_ObjType;
#if TCL_MAJOR_VERSION > 8
# define TCL_OBJTYPE_V0 0, \
0,0,0,0,0,0,0,0 /* Pre-Tcl 9 */
# define TCL_OBJTYPE_V1(a) offsetof(Tcl_ObjType, indexProc), \
a,0,0,0,0,0,0,0 /* Tcl 9 Version 1 */
# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) sizeof(Tcl_ObjType), \
a,b,c,d,e,f,g,h /* Tcl 9 - AbstractLists */
#else
# define TCL_OBJTYPE_V0 /* just empty */
# define TCL_OBJTYPE_V1(a) /* just empty */
# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) /* just empty */
#endif
/*
* The following structure stores an internal representation (internalrep) for
* a Tcl value. An internalrep is associated with an Tcl_ObjType when both
* are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern
* the handling of the internalrep.
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
void *ptr1;
void *ptr2;
} twoPtrValue;
struct { /* - internal rep as a pointer and a long, */
void *ptr; /* not used internally any more. */
unsigned long value;
} ptrAndLongRep;
} Tcl_ObjInternalRep;
/*
* One of the following structures exists for each object in the Tcl system.
* An object stores a value as either a string, some internal representation,
* or both.
*/
| > > > > | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
void *ptr1;
void *ptr2;
} twoPtrValue;
struct { /* - internal rep as a pointer and a long, */
void *ptr; /* not used internally any more. */
unsigned long value;
} ptrAndLongRep;
struct { /* - use for pointer and length reps */
void *ptr;
Tcl_Size size;
} ptrAndSize;
} Tcl_ObjInternalRep;
/*
* One of the following structures exists for each object in the Tcl system.
* An object stores a value as either a string, some internal representation,
* or both.
*/
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
* array as a readonly value. */
Tcl_Size length; /* The number of bytes at *bytes, not
* including the terminating null. */
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). */
| | > < | | 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 |
* array as a readonly value. */
Tcl_Size length; /* The number of bytes at *bytes, not
* including the terminating null. */
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).
*/
typedef struct Tcl_Namespace {
char *name; /* The namespace's name within its parent
* namespace. This contains no ::'s. The name
* of the global namespace is "" although "::"
* is an synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
void *clientData; /* Arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Function invoked when deleting the
* namespace to, e.g., free clientData. */
struct Tcl_Namespace *parentPtr;
/* Points to the namespace that contains this
* one. NULL if this is the global
|
| ︙ | ︙ | |||
798 799 800 801 802 803 804 |
* declared as "dummyX".
*
* WARNING!! The structure definition must be kept consistent with the
* CallFrame structure in tclInt.h. If you change one, change the other.
*/
typedef struct Tcl_CallFrame {
| | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 |
* declared as "dummyX".
*
* WARNING!! The structure definition must be kept consistent with the
* CallFrame structure in tclInt.h. If you change one, change the other.
*/
typedef struct Tcl_CallFrame {
Tcl_Namespace *nsPtr; /* Current namespace for the call frame. */
int dummy1;
Tcl_Size dummy2;
void *dummy3;
void *dummy4;
void *dummy5;
Tcl_Size dummy6;
void *dummy7;
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 2 if objProc was registered by
* a call to Tcl_CreateObjCommand2; 0 otherwise.
* Tcl_SetCmdInfo does not modify this field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
void *objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based function. */
| | | | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 |
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 2 if objProc was registered by
* a call to Tcl_CreateObjCommand2; 0 otherwise.
* Tcl_SetCmdInfo does not modify this field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
void *objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based function. */
void *clientData; /* ClientData for string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Function to call when command is
* deleted. */
void *deleteData; /* Value to pass to deleteProc (usually the
* same as clientData). */
Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this
* command. Note that Tcl_SetCmdInfo will not
* change a command's namespace; use
* TclRenameCommand or Tcl_Eval (of 'rename')
* to do that. */
Tcl_ObjCmdProc2 *objProc2; /* Command's object2-based function. */
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 | * o Run in iPtr->lookupNsPtr or global namespace * o Cut out of error traces * o Don't reset the flags controlling ensemble * error message rewriting. * TCL_CANCEL_UNWIND: Magical Tcl_CancelEval mode that causes the * stack for the script in progress to be * completely unwound. | | | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 | * o Run in iPtr->lookupNsPtr or global namespace * o Cut out of error traces * o Don't reset the flags controlling ensemble * error message rewriting. * TCL_CANCEL_UNWIND: Magical Tcl_CancelEval mode that causes the * stack for the script in progress to be * completely unwound. * TCL_EVAL_NOERR: Do no exception reporting at all, just return * as the caller will report. */ #define TCL_NO_EVAL 0x010000 #define TCL_EVAL_GLOBAL 0x020000 #define TCL_EVAL_DIRECT 0x040000 #define TCL_EVAL_INVOKE 0x080000 |
| ︙ | ︙ | |||
1073 1074 1075 1076 1077 1078 1079 |
*/
struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
size_t hash; /* Hash value. */
| | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 |
*/
struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
size_t hash; /* Hash value. */
void *clientData; /* Application stores something here with
* Tcl_SetHashValue. */
union { /* Key has one of these forms: */
char *oneWordValue; /* One-word value for key. */
Tcl_Obj *objPtr; /* Tcl_Obj * key value. */
int words[1]; /* Multiple integer words for key. The actual
* size will be as large as necessary for this
* table's keys. */
|
| ︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 |
* the lower bits. If this flag is set then the
* hash table will attempt to rectify this by
* randomising the bits and then using the upper
* N bits as the index into the table.
* TCL_HASH_KEY_SYSTEM_HASH - If this flag is set then all memory internally
* allocated for the hash table that is not for an
* entry will use the system heap.
*/
#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
#define TCL_HASH_KEY_SYSTEM_HASH 0x2
/*
* Structure definition for the methods associated with a hash table key type.
*/
#define TCL_HASH_KEY_TYPE_VERSION 1
struct Tcl_HashKeyType {
| > > > > > > > > | 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 |
* the lower bits. If this flag is set then the
* hash table will attempt to rectify this by
* randomising the bits and then using the upper
* N bits as the index into the table.
* TCL_HASH_KEY_SYSTEM_HASH - If this flag is set then all memory internally
* allocated for the hash table that is not for an
* entry will use the system heap.
* TCL_HASH_KEY_DIRECT_COMPARE -
* Allows fast comparison for hash keys directly
* by compare of their key.oneWordValue values,
* before call of compareKeysProc (much slower
* than a direct compare, so it is speed-up only
* flag). Don't use it if keys contain values rather
* than pointers.
*/
#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
#define TCL_HASH_KEY_SYSTEM_HASH 0x2
#define TCL_HASH_KEY_DIRECT_COMPARE 0x4
/*
* Structure definition for the methods associated with a hash table key type.
*/
#define TCL_HASH_KEY_TYPE_VERSION 1
struct Tcl_HashKeyType {
|
| ︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 |
struct Tcl_HashTable {
Tcl_HashEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables (to
* avoid mallocs and frees). */
| | | | | | 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 |
struct Tcl_HashTable {
Tcl_HashEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables (to
* avoid mallocs and frees). */
Tcl_Size numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
Tcl_Size numEntries; /* Total number of entries present in
* table. */
Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
#if TCL_MAJOR_VERSION > 8
size_t mask; /* Mask value used in hashing function. */
#endif
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
* randomized keys. */
#if TCL_MAJOR_VERSION < 9
int mask; /* Mask value used in hashing function. */
#endif
int keyType; /* Type of keys used in this table. It's
* either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
* TCL_ONE_WORD_KEYS, or an integer giving the
* number of ints that is the size of the
* key. */
Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key);
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
| | | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched,
* or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
/*
*----------------------------------------------------------------------------
* Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 |
/*
* Positions to pass to Tcl_QueueEvent/Tcl_ThreadQueueEvent:
*/
typedef enum {
TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
| | | 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
/*
* Positions to pass to Tcl_QueueEvent/Tcl_ThreadQueueEvent:
*/
typedef enum {
TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
TCL_QUEUE_ALERT_IF_EMPTY=4
} Tcl_QueuePosition;
/*
* Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
* event routines.
*/
|
| ︙ | ︙ | |||
1671 1672 1673 1674 1675 1676 1677 |
* arbitrary additional data to files in a
* filesystem. */
Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
/* Called by 'Tcl_FSFileAttrsGet()' and by
* 'file attributes'. */
Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
/* Called by 'Tcl_FSFileAttrsSet()' and by
| | | 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 |
* arbitrary additional data to files in a
* filesystem. */
Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
/* Called by 'Tcl_FSFileAttrsGet()' and by
* 'file attributes'. */
Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
/* Called by 'Tcl_FSFileAttrsSet()' and by
* 'file attributes'. */
Tcl_FSCreateDirectoryProc *createDirectoryProc;
/* Called by 'Tcl_FSCreateDirectory()'. May be
* NULL if the filesystem is read-only. */
Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
/* Called by 'Tcl_FSRemoveDirectory()'. May be
* NULL if the filesystem is read-only. */
Tcl_FSDeleteFileProc *deleteFileProc;
|
| ︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 |
* token.
*/
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD; see
* below for valid types. */
const char *start; /* First character in token. */
| | | | 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 |
* token.
*/
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD; see
* below for valid types. */
const char *start; /* First character in token. */
Tcl_Size size; /* Number of bytes in token. */
Tcl_Size numComponents; /* If this token is composed of other tokens,
* this field tells how many of them there are
* (including components of components, etc.).
* The component tokens immediately follow
* this one. */
} Tcl_Token;
/*
|
| ︙ | ︙ | |||
1879 1880 1881 1882 1883 1884 1885 |
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
| | | | 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 |
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
Tcl_Size commentSize; /* Number of bytes in comments (up through
* newline character that terminates the last
* comment). If there were no comments, this
* field is 0. */
const char *commandStart; /* First character in first word of
* command. */
Tcl_Size commandSize; /* Number of bytes in command, including first
* character of first word, up through the
* terminating newline, close bracket, or
* semicolon. */
Tcl_Size numWords; /* Total number of words in command. May be
* 0. */
Tcl_Token *tokenPtr; /* Pointer to first token representing the
* words of the command. Initially points to
|
| ︙ | ︙ | |||
1952 1953 1954 1955 1956 1957 1958 |
* encoding type. */
Tcl_EncodingConvertProc *toUtfProc;
/* Function to convert from external encoding
* into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Function to convert from UTF-8 into
* external encoding. */
| | < | | 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 |
* encoding type. */
Tcl_EncodingConvertProc *toUtfProc;
/* Function to convert from external encoding
* into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Function to convert from UTF-8 into
* external encoding. */
Tcl_FreeProc *freeProc; /* If non-NULL, function to call when this
* encoding is deleted. */
void *clientData; /* Arbitrary value associated with encoding
* type. Passed to conversion functions. */
Tcl_Size nullSize; /* Number of zero bytes that signify
* end-of-string in this encoding. This number
* is used to determine the source string
* length when the srcLen argument is
* negative. Must be 1, 2, or 4. */
} Tcl_EncodingType;
|
| ︙ | ︙ | |||
1985 1986 1987 1988 1989 1990 1991 | * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_STOPONERROR - Not used any more. | | | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 | * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_STOPONERROR - Not used any more. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills * all dstLen bytes with encoded UTF-8 content if * needed. If clear, a byte is reserved in the * dst space for NUL termination, and a * terminating NUL is appended. * TCL_ENCODING_CHAR_LIMIT - If set and dstCharsPtr is not NULL, then |
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
* argv array. */
void *srcPtr; /* Value to be used in setting dst; usage
* depends on type.*/
void *dstPtr; /* Address of value to be modified; usage
* depends on type.*/
const char *helpStr; /* Documentation message describing this
* option. */
| | | 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 |
* argv array. */
void *srcPtr; /* Value to be used in setting dst; usage
* depends on type.*/
void *dstPtr; /* Address of value to be modified; usage
* depends on type.*/
const char *helpStr; /* Documentation message describing this
* option. */
void *clientData; /* Word to pass to function callbacks. */
} Tcl_ArgvInfo;
/*
* Legal values for the type field of a Tcl_ArgInfo: see the user
* documentation for details.
*/
|
| ︙ | ︙ | |||
2186 2187 2188 2189 2190 2191 2192 | /* * Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC * argument types: */ typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr, void *dstPtr); | | | | 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 |
/*
* Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC
* argument types:
*/
typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr,
void *dstPtr);
typedef Tcl_Size (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp,
Tcl_Size objc, Tcl_Obj *const *objv, void *dstPtr);
/*
* Shorthand for commonly used argTable entries.
*/
#define TCL_ARGV_AUTO_HELP \
{TCL_ARGV_HELP, "-help", NULL, NULL, \
|
| ︙ | ︙ | |||
2281 2282 2283 2284 2285 2286 2287 | /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. */ #if TCL_MAJOR_VERSION > 8 | | | | | | | | > > | | > | | | | 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 |
/*
*----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
* stubs tables.
*/
#if TCL_MAJOR_VERSION > 8
# define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *))
#else
# define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
#endif
/*
* The following function is required to be defined in all stubs aware
* extensions. The function is actually implemented in the stub library, not
* the main Tcl library, although there is a trivial implementation in the
* main library in case an extension is statically linked into an application.
*/
const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact, int magic);
const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
const char *version, int epoch, int revision);
const char * TclInitStubTable(const char *version);
void * TclStubCall(void *arg);
#if defined(_WIN32)
TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
#else
# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL)
#endif
#ifdef USE_TCL_STUBS
#if TCL_MAJOR_VERSION < 9
# if TCL_UTF_MAX < 4
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \
TCL_STUB_MAGIC)
# else
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, "8.7b1", \
(exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \
TCL_STUB_MAGIC)
# endif
#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
TCL_STUB_MAGIC)
#else
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, (((exact)&1) ? (version) : "9.0.0"), \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
TCL_STUB_MAGIC)
#endif
#else
#if TCL_MAJOR_VERSION < 9
# define Tcl_InitStubs(interp, version, exact) \
Tcl_Panic(((void)interp, (void)version, \
(void)exact, "Please define -DUSE_TCL_STUBS"))
#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
# define Tcl_InitStubs(interp, version, exact) \
Tcl_PkgInitStubsCheck(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
#else
# define Tcl_InitStubs(interp, version, exact) \
Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \
1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
#endif
#endif
/*
* Public functions that are not accessible via the stubs table.
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
*/
#define Tcl_Main(argc, argv, proc) \
Tcl_MainEx(argc, argv, proc, \
((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp())))
EXTERN TCL_NORETURN void Tcl_MainEx(Tcl_Size argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
const char *version, int exact);
EXTERN const char * Tcl_InitSubsystems(void);
EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
EXTERN const char * Tcl_FindExecutable(const char *argv0);
EXTERN const char * Tcl_SetPreInitScript(const char *string);
EXTERN const char * Tcl_SetPanicProc(
Tcl_PanicProc *panicProc);
EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp,
const char *prefix,
Tcl_LibraryInitProc *initProc,
Tcl_LibraryInitProc *safeInitProc);
#ifndef TCL_NO_DEPRECATED
# define Tcl_StaticPackage Tcl_StaticLibrary
#endif
EXTERN Tcl_ExitProc * Tcl_SetExitProc(Tcl_ExitProc *proc);
#ifdef _WIN32
EXTERN const char * TclZipfs_AppHook(int *argc, wchar_t ***argv);
#else
EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
#endif
#if defined(_WIN32) && defined(UNICODE)
#ifndef USE_TCL_STUBS
# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
#endif
|
| ︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 |
* Tcl_DecrRefCount(objPtr);
*
* This will free the obj if there are no references to the obj.
*/
# define Tcl_BounceRefCount(objPtr) \
TclBounceRefCount(objPtr, __FILE__, __LINE__)
| | > > > > | | | | | | | | < | | > > | | | 2509 2510 2511 2512 2513 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 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 |
* Tcl_DecrRefCount(objPtr);
*
* This will free the obj if there are no references to the obj.
*/
# define Tcl_BounceRefCount(objPtr) \
TclBounceRefCount(objPtr, __FILE__, __LINE__)
static inline void
TclBounceRefCount(
Tcl_Obj* objPtr,
const char* fn,
int line)
{
if (objPtr) {
if ((objPtr)->refCount == 0) {
Tcl_DbDecrRefCount(objPtr, fn, line);
}
}
}
#else
# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
((void)++(objPtr)->refCount)
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* https://wiki.c2.com/?TrivialDoWhileLoop
*/
# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
if (_objPtr->refCount-- <= 1) { \
TclFreeObj(_objPtr); \
} \
} while(0)
# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
/*
* Declare that obj will no longer be used or referenced.
* This will free the obj if there are no references to the obj.
*/
# define Tcl_BounceRefCount(objPtr) \
TclBounceRefCount(objPtr);
static inline void
TclBounceRefCount(
Tcl_Obj* objPtr)
{
if (objPtr) {
if ((objPtr)->refCount == 0) {
Tcl_DecrRefCount(objPtr);
}
}
}
#endif
/*
|
| ︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 | *---------------------------------------------------------------------------- * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) #define Tcl_SetHashValue(h, value) ((h)->clientData = (void *)(value)) #define Tcl_GetHashKey(tablePtr, h) \ | | | | | | 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 | *---------------------------------------------------------------------------- * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) #define Tcl_SetHashValue(h, value) ((h)->clientData = (void *)(value)) #define Tcl_GetHashKey(tablePtr, h) \ ((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \ (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \ ? (h)->key.oneWordValue \ : (h)->key.string)) /* * Macros to use for clients to use to invoke find and create functions for * hash tables: */ #undef Tcl_FindHashEntry |
| ︙ | ︙ |
Changes to generic/tclAlloc.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
* enabled then a second word holds the size of the requested block, less 1,
* rounded up to a multiple of sizeof(RMAGIC). The order of elements is
* critical: ov.magic must overlay the low order bits of ov.next, and ov.magic
* can not be a valid ov.next bit pattern.
*/
union overhead {
| | | > | | | | | | < | 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 |
* enabled then a second word holds the size of the requested block, less 1,
* rounded up to a multiple of sizeof(RMAGIC). The order of elements is
* critical: ov.magic must overlay the low order bits of ov.next, and ov.magic
* can not be a valid ov.next bit pattern.
*/
union overhead {
union overhead *next; /* when free */
unsigned char padding[TCL_ALLOCALIGN];
/* align struct to TCL_ALLOCALIGN bytes */
struct {
unsigned char magic0; /* magic number */
unsigned char index; /* bucket # */
unsigned char unused; /* unused */
unsigned char magic1; /* other magic number */
#ifndef NDEBUG
unsigned short rmagic; /* range magic number */
size_t size; /* actual block size */
unsigned short unused2; /* padding to 8-byte align */
#endif
} ovu;
#define overMagic0 ovu.magic0
#define overMagic1 ovu.magic1
#define bucketIndex ovu.index
#define rangeCheckMagic ovu.rmagic
#define realBlockSize ovu.size
};
#define MAGIC 0xEF /* magic # on accounting info */
#define RMAGIC 0x5555 /* magic # on range info */
#ifndef NDEBUG
#define RSLOP sizeof(unsigned short)
#else
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | /* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is MINBLOCK bytes. The overhead information * precedes the data area returned to the user. */ | > | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
/*
* nextf[i] is the pointer to the next free block of size 2^(i+3). The
* smallest allocatable block is MINBLOCK bytes. The overhead information
* precedes the data area returned to the user.
*/
#define MINBLOCK \
((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1))
#define NBUCKETS (13 - (MINBLOCK >> 4))
#define MAXMALLOC ((size_t)1 << (NBUCKETS+2))
static union overhead *nextf[NBUCKETS];
/*
* The following structure is used to keep track of all system memory
* currently owned by Tcl. When finalizing, all this memory will be returned
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 | * None. * *---------------------------------------------------------------------- */ void * TclpAlloc( | | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
size_t numBytes) /* Number of bytes to allocate. */
{
union overhead *overPtr;
size_t bucket;
size_t amount;
struct block *bigBlockPtr = NULL;
if (!allocInit) {
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | * Attempts to get more memory from the system. * *---------------------------------------------------------------------- */ static void MoreCore( | | | | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
* Attempts to get more memory from the system.
*
*----------------------------------------------------------------------
*/
static void
MoreCore(
size_t bucket) /* What bucket to allocate to. */
{
union overhead *overPtr;
size_t size; /* size of desired block */
size_t amount; /* amount to allocate */
size_t numBlocks; /* how many blocks we get */
struct block *blockPtr;
/*
* sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a
* VAX, I think) or for a negative arg.
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloc'ed block. */
| | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloc'ed block. */
size_t numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
size_t maxSize;
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
| | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
size_t numBytes) /* New size of memory. */
{
return realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
#else
TCL_MAC_EMPTY_FILE(generic_tclAlloc_c)
|
| ︙ | ︙ |
Changes to generic/tclArithSeries.c.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 49 50 51 52 |
*/
/*
* The structure used for the ArithSeries internal representation.
* Note that the len can in theory be always computed by start,end,step
* but it's faster to cache it inside the internal representation.
*/
typedef struct {
Tcl_Size len;
Tcl_Obj **elements;
int isDouble;
| > > > | > > | | > < < < > < | < > | | | | | > | > | | | > | > | | | > > | | > > > | > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > | | | < | < | > > | | < < | | | < | | > | | | | | | > > > | > > > > > | | > | > > > > > | | | > > > > > | > > | > | > > > | > | > > | < < | | | | | < | | | < | | > > > | > | > > | > > > > > > > > > | | > > > > > > > > > > > > > > > | | > > > > > > > > | > > > > | | > | > > | | < < | < < < < < < < | < < < < < < < < < | > > | | < | | > | | | | | | > > > > > > | > | > > > | | < | | > < | > | | > | | > > | | | | | | | | | > < | | < | < | < | > > > > | | | | | | | | | < < | < | | > | | | > > | > > > | | > > | > > | | > | > > | > > < | | < | | < < | | > > | > > | | < < | < | | | | > | > | | | > | | > > | | > > > > > > > | > > > > > > > > > > < | < > | | > > > > > > | < | | | > > > > > > > > > > | > > > | | > | > | < | < | | < | | | | | 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 |
*/
/*
* The structure used for the ArithSeries internal representation.
* Note that the len can in theory be always computed by start,end,step
* but it's faster to cache it inside the internal representation.
*/
typedef struct {
Tcl_Size len;
Tcl_Obj **elements;
int isDouble;
Tcl_Size refCount;
} ArithSeries;
typedef struct {
ArithSeries base;
Tcl_WideInt start;
Tcl_WideInt step;
} ArithSeriesInt;
typedef struct {
ArithSeries base;
double start;
double step;
unsigned precision; /* Number of decimal places to render. */
} ArithSeriesDbl;
/* Forward declarations. */
static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *arithSeriesObj, Tcl_Size index,
Tcl_Obj **elemObj);
static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj);
static int TclArithSeriesObjRange(Tcl_Interp *interp,
Tcl_Obj *arithSeriesObj, Tcl_Size fromIdx,
Tcl_Size toIdx, Tcl_Obj **newObjPtr);
static int TclArithSeriesObjReverse(Tcl_Interp *interp,
Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr);
static int TclArithSeriesGetElements(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Size *objcPtr,
Tcl_Obj ***objvPtr);
static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr);
static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
static int SetArithSeriesFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static int ArithSeriesInOperation(Tcl_Interp *interp,
Tcl_Obj *valueObj, Tcl_Obj *arithSeriesObj,
int *boolResult);
/* ------------------------ ArithSeries object type -------------------------- */
static const Tcl_ObjType arithSeriesType = {
"arithseries", /* name */
FreeArithSeriesInternalRep, /* freeIntRepProc */
DupArithSeriesInternalRep, /* dupIntRepProc */
UpdateStringOfArithSeries, /* updateStringProc */
SetArithSeriesFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V2(
ArithSeriesObjLength,
TclArithSeriesObjIndex,
TclArithSeriesObjRange,
TclArithSeriesObjReverse,
TclArithSeriesGetElements,
NULL, // SetElement
NULL, // Replace
ArithSeriesInOperation) // "in" operator
};
/*
* Helper functions
*
* - power10 -- Fast version of pow(10, (int) n) for common cases.
* - ArithRound -- Round doubles to the number of significant fractional
* digits
* - ArithSeriesIndexDbl -- base list indexing operation for doubles
* - ArithSeriesIndexInt -- " " " " " integers
* - ArithSeriesGetInternalRep -- Return the internal rep from a Tcl_Obj
* - Precision -- determine the number of factional digits for the given
* double value
* - maxPrecision -- Using the values provide, determine the longest percision
* in the arithSeries
*/
static inline double
power10(
unsigned n)
{
/* few "precomputed" powers (note, max double is mostly 1.7e+308) */
static const double powers[] = {
1, 10, 100, 1000, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10,
1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20,
1e21, 1e22, 1e23, 1e24, 1e25, 1e26, 1e27, 1e28, 1e29, 1e30,
1e31, 1e32, 1e33, 1e34, 1e35, 1e36, 1e37, 1e38, 1e39, 1e40,
1e41, 1e42, 1e43, 1e44, 1e45, 1e46, 1e47, 1e48, 1e49, 1e50
};
if (n < sizeof(powers) / sizeof(*powers)) {
return powers[n];
} else {
// Not an expected case. Doesn't need to be so fast
return pow(10, n);
}
}
static inline double
ArithRound(
double d,
unsigned n)
{
double scaleFactor;
if (!n) {
return d;
}
scaleFactor = power10(n);
return round(d * scaleFactor) / scaleFactor;
}
static inline double
ArithSeriesEndDbl(
ArithSeriesDbl *dblRepPtr)
{
double d;
if (!dblRepPtr->base.len) {
return dblRepPtr->start;
}
d = dblRepPtr->start + ((dblRepPtr->base.len-1) * dblRepPtr->step);
return ArithRound(d, dblRepPtr->precision);
}
static inline Tcl_WideInt
ArithSeriesEndInt(
ArithSeriesInt *intRepPtr)
{
if (!intRepPtr->base.len) {
return intRepPtr->start;
}
return intRepPtr->start + ((intRepPtr->base.len-1) * intRepPtr->step);
}
static inline double
ArithSeriesIndexDbl(
ArithSeries *arithSeriesRepPtr,
Tcl_WideInt index)
{
ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *)arithSeriesRepPtr;
assert(arithSeriesRepPtr->isDouble);
double d = dblRepPtr->start;
if (index) {
d += (index * dblRepPtr->step);
}
return ArithRound(d, dblRepPtr->precision);
}
static inline Tcl_WideInt
ArithSeriesIndexInt(
ArithSeries *arithSeriesRepPtr,
Tcl_WideInt index)
{
ArithSeriesInt *intRepPtr = (ArithSeriesInt *)arithSeriesRepPtr;
assert(!arithSeriesRepPtr->isDouble);
return intRepPtr->start + (index * intRepPtr->step);
}
static inline ArithSeries *
ArithSeriesGetInternalRep(
Tcl_Obj *objPtr)
{
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr,
&arithSeriesType);
return irPtr ? (ArithSeries *) irPtr->twoPtrValue.ptr1 : NULL;
}
/*
* Compute number of significant fractional digits
*/
static inline unsigned
ObjPrecision(
Tcl_Obj *numObj)
{
void *ptr;
int type;
if (TclHasInternalRep(numObj, &tclDoubleType) || (
Tcl_GetNumberFromObj(NULL, numObj, &ptr, &type) == TCL_OK &&
type == TCL_NUMBER_DOUBLE
)
) { /* TCL_NUMBER_DOUBLE */
const char *str = TclGetString(numObj);
if (strchr(str, 'e') == NULL && strchr(str, 'E') == NULL) {
str = strchr(str, '.');
return (str ? strlen(str + 1) : 0);
}
/* don't calculate precision for e-notation */
}
/* no fraction for TCL_NUMBER_NAN, TCL_NUMBER_INT, TCL_NUMBER_BIG */
return 0;
}
/*
* Find longest number of digits after the decimal point.
*/
static inline unsigned
maxObjPrecision(
Tcl_Obj *start,
Tcl_Obj *end,
Tcl_Obj *step)
{
unsigned i, dp = 0;
if (step) {
dp = ObjPrecision(step);
}
if (start) {
i = ObjPrecision(start);
if (i > dp) {
dp = i;
}
}
if (end) {
i = ObjPrecision(end);
if (i > dp) {
dp = i;
}
}
return dp;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesLen --
*
* Compute the length of the equivalent list where
* every element is generated starting from *start*,
* and adding *step* to generate every successive element
* that's < *end* for positive steps, or > *end* for negative
* steps.
*
* Results:
* The length of the list generated by the given range,
* that may be zero.
* The function returns -1 if the list is of length infinite.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
ArithSeriesLenInt(
Tcl_WideInt start,
Tcl_WideInt end,
Tcl_WideInt step)
{
Tcl_WideInt len;
if (step == 0) {
return 0;
}
len = (end - start) / step + 1;
if (len < 0) {
return 0;
}
return len;
}
static Tcl_WideInt
ArithSeriesLenDbl(
double start,
double end,
double step,
unsigned precision)
{
double scaleFactor;
volatile double len; /* use volatile for more deterministic cross-platform
* FP arithmetics, (e. g. to avoid wrong optimization
* and divergent results by different compilers/platforms
* with and w/o FPU_INLINE_ASM, _CONTROLFP, etc) */
if (step == 0) {
return 0;
}
if (precision) {
scaleFactor = power10(precision);
start *= scaleFactor;
end *= scaleFactor;
step *= scaleFactor;
}
/* distance */
end -= start;
/*
* To improve numerical stability use wide arithmetic instead of IEEE-754
* when distance and step do not exceed wide-integers.
*/
if (
((double)WIDE_MIN <= end && end <= (double)WIDE_MAX) &&
((double)WIDE_MIN <= step && step <= (double)WIDE_MAX)
) {
Tcl_WideInt iend = end < 0 ? end - 0.5 : end + 0.5;
Tcl_WideInt istep = step < 0 ? step - 0.5 : step + 0.5;
if (istep) { /* avoid div by zero, steps like 0.1, precision 0 */
return (iend / istep) + 1;
}
}
/*
* Too large, so use double (note the result may be instable due
* to IEEE-754, so to be as precise as possible we'll use volatile len)
*/
len = (end / step) + 1;
if (len >= (double)TCL_SIZE_MAX) {
return TCL_SIZE_MAX;
}
if (len < 0) {
return 0;
}
return (Tcl_WideInt)len;
}
/*
*----------------------------------------------------------------------
*
* DupArithSeriesInternalRep --
*
* Initialize the internal representation of a arithseries Tcl_Obj to a
* copy of the internal representation of an existing arithseries object.
* The copy does not share the cache of the elements.
*
* Results:
* None.
*
* Side effects:
* We set "copyPtr"s internal rep to a pointer to a
* newly allocated ArithSeries structure.
*
*----------------------------------------------------------------------
*/
static void
DupArithSeriesInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ArithSeries *srcRepPtr = (ArithSeries *)
srcPtr->internalRep.twoPtrValue.ptr1;
srcRepPtr->refCount++;
copyPtr->internalRep.twoPtrValue.ptr1 = srcRepPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = &arithSeriesType;
}
/*
*----------------------------------------------------------------------
*
* FreeArithSeriesInternalRep --
*
* Free any allocated memory in the ArithSeries Rep
*
* Results:
* None.
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static inline void
FreeElements(
ArithSeries *arithSeriesRepPtr)
{
if (arithSeriesRepPtr->elements) {
Tcl_WideInt i, len = arithSeriesRepPtr->len;
for (i=0; i<len; i++) {
Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
}
Tcl_Free((void *)arithSeriesRepPtr->elements);
arithSeriesRepPtr->elements = NULL;
}
}
static void
FreeArithSeriesInternalRep(
Tcl_Obj *arithSeriesObjPtr)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
if (arithSeriesRepPtr && arithSeriesRepPtr->refCount-- <= 1) {
FreeElements(arithSeriesRepPtr);
Tcl_Free((void *)arithSeriesRepPtr);
}
}
/*
*----------------------------------------------------------------------
*
* NewArithSeriesInt --
*
* Creates a new ArithSeries object. The returned object has
* refcount = 0.
*
* Results:
* A Tcl_Obj pointer to the created ArithSeries object.
* A NULL pointer of the range is invalid.
*
* Side Effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
NewArithSeriesInt(
Tcl_WideInt start,
Tcl_WideInt step,
Tcl_WideInt len)
{
Tcl_WideInt length;
Tcl_Obj *arithSeriesObj;
ArithSeriesInt *arithSeriesRepPtr;
length = len>=0 ? len : -1;
if (length < 0) {
length = -1;
}
TclNewObj(arithSeriesObj);
if (length <= 0) {
return arithSeriesObj;
}
arithSeriesRepPtr = (ArithSeriesInt *) Tcl_Alloc(sizeof(ArithSeriesInt));
arithSeriesRepPtr->base.len = length;
arithSeriesRepPtr->base.elements = NULL;
arithSeriesRepPtr->base.isDouble = 0;
arithSeriesRepPtr->base.refCount = 1;
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->step = step;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
arithSeriesObj->typePtr = &arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
}
return arithSeriesObj;
}
/*
*----------------------------------------------------------------------
*
* NewArithSeriesDbl --
*
* Creates a new ArithSeries object with doubles. The returned object has
* refcount = 0.
*
* Results:
* A Tcl_Obj pointer to the created ArithSeries object.
* A NULL pointer of the range is invalid.
*
* Side Effects:
* None.
*----------------------------------------------------------------------
*/
static Tcl_Obj *
NewArithSeriesDbl(
double start,
double step,
Tcl_WideInt len,
unsigned precision)
{
Tcl_WideInt length;
Tcl_Obj *arithSeriesObj;
ArithSeriesDbl *arithSeriesRepPtr;
length = len>=0 ? len : -1;
if (length < 0) {
length = -1;
}
TclNewObj(arithSeriesObj);
if (length <= 0) {
return arithSeriesObj;
}
arithSeriesRepPtr = (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl));
arithSeriesRepPtr->base.len = length;
arithSeriesRepPtr->base.elements = NULL;
arithSeriesRepPtr->base.isDouble = 1;
arithSeriesRepPtr->base.refCount = 1;
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->precision = precision;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
arithSeriesObj->typePtr = &arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
}
return arithSeriesObj;
}
/*
*----------------------------------------------------------------------
*
* assignNumber --
*
* Create the appropriate Tcl_Obj value for the given numeric values.
* Used locally only for decoding [lseq] numeric arguments.
* refcount = 0.
*
* Results:
* A Tcl_Obj pointer. No assignment on error.
*
* Side Effects:
* None.
*----------------------------------------------------------------------
*/
static int
assignNumber(
Tcl_Interp *interp,
int useDoubles,
Tcl_WideInt *intNumberPtr,
double *dblNumberPtr,
Tcl_Obj *numberObj)
{
void *ptr;
int type;
if (Tcl_GetNumberFromObj(interp, numberObj, &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_BIG) {
/* bignum is not supported yet. */
Tcl_WideInt w;
(void)Tcl_GetWideIntFromObj(interp, numberObj, &w);
return TCL_ERROR;
}
if (useDoubles) {
if (type != TCL_NUMBER_INT) {
double value = *(double *)ptr;
*intNumberPtr = (Tcl_WideInt)value;
*dblNumberPtr = value;
} else {
Tcl_WideInt value = *(Tcl_WideInt *)ptr;
*intNumberPtr = value;
*dblNumberPtr = (double)value;
}
} else {
if (type == TCL_NUMBER_INT) {
Tcl_WideInt value = *(Tcl_WideInt *)ptr;
*intNumberPtr = value;
*dblNumberPtr = (double)value;
} else {
double value = *(double *)ptr;
*intNumberPtr = (Tcl_WideInt)value;
*dblNumberPtr = value;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclNewArithSeriesObj --
*
* Creates a new ArithSeries object. Some arguments may be NULL and will
* be computed based on the other given arguments.
* refcount = 0.
*
* Results:
* A Tcl_Obj pointer to the created ArithSeries object.
* NULL if the range is invalid.
*
* Side Effects:
* None.
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclNewArithSeriesObj(
Tcl_Interp *interp, /* For error reporting */
int useDoubles, /* Flag indicates values start,
** end, step, are treated as doubles */
Tcl_Obj *startObj, /* Starting value */
Tcl_Obj *endObj, /* Ending limit */
Tcl_Obj *stepObj, /* increment value */
Tcl_Obj *lenObj) /* Number of elements */
{
double dstart, dend, dstep = 1.0;
Tcl_WideInt start, end, step = 1;
Tcl_WideInt len = -1;
Tcl_Obj *objPtr;
unsigned precision = (unsigned)-1; /* unknown precision */
if (startObj) {
if (assignNumber(interp, useDoubles, &start, &dstart, startObj) != TCL_OK) {
return NULL;
}
} else {
start = 0;
dstart = 0.0;
}
if (stepObj) {
if (assignNumber(interp, useDoubles, &step, &dstep, stepObj) != TCL_OK) {
return NULL;
}
if (!useDoubles ? !step : !dstep) {
TclNewObj(objPtr);
return objPtr;
}
}
if (endObj) {
if (assignNumber(interp, useDoubles, &end, &dend, endObj) != TCL_OK) {
return NULL;
}
}
if (lenObj) {
if (Tcl_GetWideIntFromObj(interp, lenObj, &len) != TCL_OK) {
return NULL;
}
}
if (endObj) {
if (!stepObj) {
if (useDoubles) {
if (dstart > dend) {
dstep = -1.0;
step = -1;
}
} else {
if (start > end) {
step = -1;
dstep = -1.0;
}
}
}
assert(dstep!=0);
if (!lenObj) {
if (useDoubles) {
if (isinf(dstart) || isinf(dend)) {
goto exceeded;
}
if (isnan(dstart) || isnan(dend)) {
const char *description = "non-numeric floating-point value";
char tmp[TCL_DOUBLE_SPACE + 2];
tmp[0] = '\0';
Tcl_PrintDouble(NULL, isnan(dstart)?dstart:dend, tmp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot use %s \"%s\" to estimate length of arith-series",
description, tmp));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description,
(char *)NULL);
return NULL;
}
precision = maxObjPrecision(startObj, endObj, stepObj);
len = ArithSeriesLenDbl(dstart, dend, dstep, precision);
} else {
len = ArithSeriesLenInt(start, end, step);
}
}
} else {
if (useDoubles) {
// Compute precision based on given command argument values
precision = maxObjPrecision(startObj, NULL, stepObj);
dend = dstart + (dstep * (len-1));
// Make computed end value match argument(s) precision
dend = ArithRound(dend, precision);
end = dend;
} else {
end = start + (step * (len - 1));
dend = end;
}
}
/*
* todo: check whether the boundary must be rather LIST_MAX, to be more
* similar to plain lists, otherwise it'd generare an error or panic later
* (0x0ffffffffffffffa instead of 0x7fffffffffffffff by 64bit)
*/
if (len > TCL_SIZE_MAX) {
exceeded:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"max length of a Tcl list exceeded", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
return NULL;
}
if (useDoubles) {
/* ensure we'll not get NaN somewhere in the arith-series,
* so simply check the end of it and behave like [expr {Inf - Inf}] */
double d = dstart + (len - 1) * dstep;
if (isnan(d)) {
const char *s = "domain error: argument not in valid range";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *)NULL);
return NULL;
}
if (precision == (unsigned)-1) {
precision = maxObjPrecision(startObj, endObj, stepObj);
}
objPtr = NewArithSeriesDbl(dstart, dstep, len, precision);
} else {
objPtr = NewArithSeriesInt(start, step, len);
}
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* TclArithSeriesObjIndex --
*
* Returns the element with the specified index in the list
* represented by the specified Arithmetic Sequence object.
* If the index is out of range, TCL_ERROR is returned,
* otherwise TCL_OK is returned and the integer value of the
* element is stored in *element.
*
* Results:
* TCL_OK on success.
*
* Side Effects:
* On success, the integer pointed by *element is modified.
* An empty string ("") is assigned if index is out-of-bounds.
*
*----------------------------------------------------------------------
*/
int
TclArithSeriesObjIndex(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *arithSeriesObj, /* List obj */
Tcl_Size index, /* index to element of interest */
Tcl_Obj **elemObj) /* Return value */
{
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (index < 0 || arithSeriesRepPtr->len <= index) {
*elemObj = NULL;
} else {
/* List[i] = Start + (Step * index) */
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 | *---------------------------------------------------------------------- * * ArithSeriesObjLength * * Returns the length of the arithmetic series. * * Results: | < | < | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < | < | | 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 |
*----------------------------------------------------------------------
*
* ArithSeriesObjLength
*
* Returns the length of the arithmetic series.
*
* Results:
* The length of the series as Tcl_WideInt.
*
* Side Effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
ArithSeriesObjLength(
Tcl_Obj *arithSeriesObj)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
arithSeriesObj->internalRep.twoPtrValue.ptr1;
return arithSeriesRepPtr->len;
}
/*
* SetArithSeriesFromAny --
*
* The Arithmetic Series object is just an way to optimize
* Lists space complexity, so no one should try to convert
* a string to an Arithmetic Series object.
*
* This function is here just to populate the Type structure.
*
* Results:
* The result is always TCL_ERROR. But see Side Effects.
*
* Side effects:
* Tcl Panic if called.
*
*----------------------------------------------------------------------
*/
static int
SetArithSeriesFromAny(
TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj, /* List object to take a range from. */
Tcl_Size fromIdx, /* Index of first element to include. */
Tcl_Size toIdx, /* Index of last element to include. */
Tcl_Obj **newObjPtr) /* return value */
{
ArithSeries *arithSeriesRepPtr;
| | | < < < | > | < | < | < | < > | < | < < < < < | < | < | | | | | < | < < < < < < < | < < | | < | | > | | > > > > > > > > > > > | < | < | | | | | < < < < | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 |
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj, /* List object to take a range from. */
Tcl_Size fromIdx, /* Index of first element to include. */
Tcl_Size toIdx, /* Index of last element to include. */
Tcl_Obj **newObjPtr) /* return value */
{
ArithSeries *arithSeriesRepPtr;
Tcl_WideInt len;
(void)interp; /* silence compiler */
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = 0;
}
if (toIdx >= arithSeriesRepPtr->len) {
toIdx = arithSeriesRepPtr->len-1;
}
if (fromIdx > toIdx || fromIdx >= arithSeriesRepPtr->len) {
TclNewObj(*newObjPtr);
return TCL_OK;
}
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx < 0) {
toIdx = 0;
}
len = toIdx - fromIdx + 1;
if (arithSeriesRepPtr->isDouble) {
ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *)arithSeriesRepPtr;
double dstart = ArithSeriesIndexDbl(arithSeriesRepPtr, fromIdx);
if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesRepPtr->refCount > 1))) {
/* as new object */
*newObjPtr = NewArithSeriesDbl(dstart, dblRepPtr->step, len,
dblRepPtr->precision);
} else {
/* in-place is possible */
*newObjPtr = arithSeriesObj;
/*
* Even if nothing below causes any changes, we still want the
* string-canonizing effect of [lrange 0 end].
*/
TclInvalidateStringRep(arithSeriesObj);
dblRepPtr->start = dstart;
/* step and precision remain the same */
dblRepPtr->base.len = len;
FreeElements(arithSeriesRepPtr);
}
} else {
ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr;
Tcl_WideInt start = ArithSeriesIndexInt(arithSeriesRepPtr, fromIdx);
if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesRepPtr->refCount > 1))) {
/* as new object */
*newObjPtr = NewArithSeriesInt(start, intRepPtr->step, len);
} else {
/* in-place is possible. */
*newObjPtr = arithSeriesObj;
/*
* Even if nothing below causes any changes, we still want the
* string-canonizing effect of [lrange 0 end].
*/
TclInvalidateStringRep(arithSeriesObj);
intRepPtr->start = start;
/* step remains the same */
intRepPtr->base.len = len;
FreeElements(arithSeriesRepPtr);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclArithSeriesGetElements --
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
Tcl_Obj *objPtr, /* ArithSeries object for which an element
* array is to be returned. */
Tcl_Size *objcPtr, /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
{
| | | < < | < | | < | > | > > > | < | | | 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 |
Tcl_Obj *objPtr, /* ArithSeries object for which an element
* array is to be returned. */
Tcl_Size *objcPtr, /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
{
if (TclHasInternalRep(objPtr, &arithSeriesType)) {
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr);
Tcl_Obj **objv;
Tcl_Size objc = arithSeriesRepPtr->len;
if (objc > 0) {
if (arithSeriesRepPtr->elements) {
/* If this exists, it has already been populated */
objv = arithSeriesRepPtr->elements;
} else {
/* Construct the elements array */
objv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj*) * objc);
if (objv == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"max length of a Tcl list exceeded",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return TCL_ERROR;
}
arithSeriesRepPtr->elements = objv;
Tcl_Size i;
for (i = 0; i < objc; i++) {
int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]);
if (status) {
return TCL_ERROR;
}
Tcl_IncrRefCount(objv[i]);
}
}
} else {
objv = NULL;
}
*objvPtr = objv;
*objcPtr = objc;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"value is not an arithseries", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", (char *)NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 |
int
TclArithSeriesObjReverse(
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj, /* List object to reverse. */
Tcl_Obj **newObjPtr)
{
ArithSeries *arithSeriesRepPtr;
| < < < < | < | < | | | < < < < | < | < < < < < < | < < < < < < | < < < < < < | > < < | | | | < | > < | < | | < < | | < < | < < < < < | | 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 |
int
TclArithSeriesObjReverse(
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj, /* List object to reverse. */
Tcl_Obj **newObjPtr)
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *resultObj;
(void)interp;
assert(newObjPtr != NULL);
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (Tcl_IsShared(arithSeriesObj) || (arithSeriesRepPtr->refCount > 1)) {
if (arithSeriesRepPtr->isDouble) {
ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *)arithSeriesRepPtr;
resultObj = NewArithSeriesDbl(ArithSeriesEndDbl(dblRepPtr),
-dblRepPtr->step, arithSeriesRepPtr->len, dblRepPtr->precision);
} else {
ArithSeriesInt *intRepPtr = (ArithSeriesInt *)arithSeriesRepPtr;
resultObj = NewArithSeriesInt(ArithSeriesEndInt(intRepPtr),
-intRepPtr->step, arithSeriesRepPtr->len);
}
} else {
/*
* In-place is possible.
*/
TclInvalidateStringRep(arithSeriesObj);
if (arithSeriesRepPtr->isDouble) {
ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *)arithSeriesRepPtr;
dblRepPtr->start = ArithSeriesEndDbl(dblRepPtr);
dblRepPtr->step = -dblRepPtr->step;
/* precision remains the same */
} else {
ArithSeriesInt *intRepPtr = (ArithSeriesInt *)arithSeriesRepPtr;
intRepPtr->start = ArithSeriesEndInt(intRepPtr);
intRepPtr->step = -intRepPtr->step;
}
FreeElements(arithSeriesRepPtr);
resultObj = arithSeriesObj;
}
*newObjPtr = resultObj;
return resultObj ? TCL_OK : TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfArithSeries --
*
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 | * Side effects: * The object's string is set to a valid string that results from * the list-to-string conversion. This string will be empty if the * list has no elements. The list internal representation * should not be NULL and we assume it is not NULL. * * Notes: | | | | | | < | > | > < > > > > > | | > > | | > | | > > < > | > > | > > | > > | < | > | < < > > | > | | | 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 |
* Side effects:
* The object's string is set to a valid string that results from
* the list-to-string conversion. This string will be empty if the
* list has no elements. The list internal representation
* should not be NULL and we assume it is not NULL.
*
* Notes:
* At the cost of overallocation it's possible to estimate
* the length of the string representation and make this procedure
* much faster. Because the programmer shouldn't expect the
* string conversion of a big arithmetic sequence to be fast
* this version takes more care of space than time.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfArithSeries(
Tcl_Obj *arithSeriesObjPtr)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
char *p;
Tcl_Size i, bytlen = 0;
if (!arithSeriesRepPtr->len) {
TclInitEmptyStringRep(arithSeriesObjPtr);
return;
}
/*
* Pass 1: estimate space.
*/
if (!arithSeriesRepPtr->isDouble) {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
double d = (double)ArithSeriesIndexInt(arithSeriesRepPtr, i);
Tcl_Size slen = d>0 ? log10(d)+1 : d<0 ? log10(-d)+2 : 1;
bytlen += slen;
}
} else {
char tmp[TCL_DOUBLE_SPACE + 2];
for (i = 0; i < arithSeriesRepPtr->len; i++) {
double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
tmp[0] = '\0';
Tcl_PrintDouble(NULL,d,tmp);
bytlen += strlen(tmp);
if (bytlen > TCL_SIZE_MAX) {
/* overflow, todo: check we could use some representation instead of the panic
* to signal it is too large for string representation, because too heavy */
Tcl_Panic("UpdateStringOfArithSeries: too large to represent");
}
}
}
bytlen += arithSeriesRepPtr->len; // Space for each separator
/*
* Pass 2: generate the string repr.
*/
p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen);
if (!arithSeriesRepPtr->isDouble) {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
Tcl_WideInt d = ArithSeriesIndexInt(arithSeriesRepPtr, i);
p += TclFormatInt(p, d);
assert(p - arithSeriesObjPtr->bytes <= bytlen);
*p++ = ' ';
}
} else {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
*p = '\0';
Tcl_PrintDouble(NULL,d,p);
p += strlen(p);
assert(p - arithSeriesObjPtr->bytes <= bytlen);
*p++ = ' ';
}
}
*(--p) = '\0';
arithSeriesObjPtr->length = p - arithSeriesObjPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesInOperator --
*
|
| ︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 |
static int
ArithSeriesInOperation(
Tcl_Interp *interp,
Tcl_Obj *valueObj,
Tcl_Obj *arithSeriesObjPtr,
int *boolResult)
{
| > | < | > | > > | > | > > | | > | 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 |
static int
ArithSeriesInOperation(
Tcl_Interp *interp,
Tcl_Obj *valueObj,
Tcl_Obj *arithSeriesObjPtr,
int *boolResult)
{
ArithSeries *repPtr = (ArithSeries *)
arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
int status;
Tcl_Size index, incr, elen, vlen;
if (repPtr->isDouble) {
ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) repPtr;
double y;
int test = 0;
incr = 0; // Check index+incr where incr is 0 and 1
status = Tcl_GetDoubleFromObj(interp, valueObj, &y);
if (status != TCL_OK) {
test = 0;
} else {
const char *vstr = TclGetStringFromObj(valueObj, &vlen);
index = (y - dblRepPtr->start) / dblRepPtr->step;
while (incr<2) {
Tcl_Obj *elemObj;
elen = 0;
TclArithSeriesObjIndex(interp, arithSeriesObjPtr, (index+incr), &elemObj);
const char *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : "";
/* "in" operation defined as a string compare */
test = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0;
Tcl_BounceRefCount(elemObj);
/* Stop if we have a match */
if (test) {
break;
}
incr++;
}
}
if (boolResult) {
*boolResult = test;
}
} else {
ArithSeriesInt *intRepPtr = (ArithSeriesInt *) repPtr;
Tcl_WideInt y;
status = Tcl_GetWideIntFromObj(NULL, valueObj, &y);
if (status != TCL_OK) {
if (boolResult) {
*boolResult = 0;
}
} else {
Tcl_Obj *elemObj;
elen = 0;
index = (y - intRepPtr->start) / intRepPtr->step;
TclArithSeriesObjIndex(interp, arithSeriesObjPtr, index, &elemObj);
char const *vstr = TclGetStringFromObj(valueObj, &vlen);
char const *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : "";
if (boolResult) {
*boolResult = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0;
}
Tcl_BounceRefCount(elemObj);
}
}
return TCL_OK;
|
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
* State identified for a basic block's catch context.
*/
typedef enum BasicBlockCatchState {
BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */
BBCS_NONE, /* Block is outside of any catch */
BBCS_INCATCH, /* Block is within a catch context */
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
* State identified for a basic block's catch context.
*/
typedef enum BasicBlockCatchState {
BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */
BBCS_NONE, /* Block is outside of any catch */
BBCS_INCATCH, /* Block is within a catch context */
BBCS_CAUGHT /* Block is within a catch context and
* may be executed after an exception fires */
} BasicBlockCatchState;
/*
* Structure that defines a basic block - a linear sequence of bytecode
* instructions with no jumps in or out (including not changing the
* state of any exception range).
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
Tcl_StoreInternalRep(objPtr, &assembleCodeType, NULL);
}
/*
* Set up the compilation environment, and assemble the code.
*/
| | | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
Tcl_StoreInternalRep(objPtr, &assembleCodeType, NULL);
}
/*
* Set up the compilation environment, and assemble the code.
*/
source = TclGetStringFromObj(objPtr, &sourceLen);
TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0);
status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT);
if (status != TCL_OK) {
/*
* Assembly failed. Clean up and report the error.
*/
TclFreeCompileEnv(&compEnv);
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 |
codePtr->localCachePtr->refCount++;
}
/*
* Report on what the assembler did.
*/
| < < | < < < | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 |
codePtr->localCachePtr->refCount++;
}
/*
* Report on what the assembler did.
*/
TclDebugPrintByteCodeObj(objPtr);
return codePtr;
}
/*
*-----------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 |
/*
* Compile the code and convert any error from the compilation into
* bytecode reporting the error;
*/
if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
tokenPtr[1].size, TCL_EVAL_DIRECT)) {
| < | 977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
/*
* Compile the code and convert any error from the compilation into
* bytecode reporting the error;
*/
if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
tokenPtr[1].size, TCL_EVAL_DIRECT)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s\" body, line %d)",
(int)parsePtr->tokenPtr->size, parsePtr->tokenPtr->start,
Tcl_GetErrorLine(interp)));
envPtr->numCommands = numCommands;
envPtr->codeNext = envPtr->codeStart + offset;
envPtr->currStackDepth = depth;
|
| ︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 |
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
| | | 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
break;
case ASSEM_1BYTE:
if (parsePtr->numWords != 1) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
|
| ︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 |
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
if (opnd < 0 || opnd > 3) {
Tcl_SetObjResult(interp,
| | | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 |
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
if (opnd < 0 || opnd > 3) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operand must be [0..3]", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", (char *)NULL);
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
break;
case ASSEM_CONCAT1:
if (parsePtr->numWords != 2) {
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
TalInstructionTable+tblIdx);
} else if (GetNextOperand(assemEnvPtr, &tokenPtr,
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
| | | 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 |
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
TalInstructionTable+tblIdx);
} else if (GetNextOperand(assemEnvPtr, &tokenPtr,
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
/*
* Assumes that PUSH is the first slot!
*/
BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
|
| ︙ | ︙ | |||
1622 1623 1624 1625 1626 1627 1628 |
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
if (opnd < 2) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operand must be >=2", -1));
| | | 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 |
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
if (opnd < 2) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operand must be >=2", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", (char *)NULL);
}
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
break;
case ASSEM_LVT:
|
| ︙ | ︙ | |||
1932 1933 1934 1935 1936 1937 1938 |
*/
DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
curr_bb, exceptionCount, savedExceptArrayNext);
curr_bb->foreignExceptionBase = savedExceptArrayNext;
curr_bb->foreignExceptionCount = exceptionCount;
curr_bb->foreignExceptions =
| | | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 |
*/
DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
curr_bb, exceptionCount, savedExceptArrayNext);
curr_bb->foreignExceptionBase = savedExceptArrayNext;
curr_bb->foreignExceptionCount = exceptionCount;
curr_bb->foreignExceptions =
(ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange));
memcpy(curr_bb->foreignExceptions,
envPtr->exceptArrayPtr + savedExceptArrayNext,
exceptionCount * sizeof(ExceptionRange));
for (i = 0; i < exceptionCount; ++i) {
curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
}
envPtr->exceptArrayNext = savedExceptArrayNext;
|
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
JumptableInfo* jtPtr;
Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */
Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */
int isNew; /* Flag==1 if the key is not yet in the
* table. */
Tcl_Size i;
| | | | | 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 |
JumptableInfo* jtPtr;
Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */
Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */
int isNew; /* Flag==1 if the key is not yet in the
* table. */
Tcl_Size i;
if (TclListObjLength(interp, jumps, &objc) != TCL_OK) {
return TCL_ERROR;
}
if (objc % 2 != 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"jump table must have an even number of list elements",
-1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", (char *)NULL);
}
return TCL_ERROR;
}
if (TclListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Allocate the jumptable.
*/
|
| ︙ | ︙ | |||
2019 2020 2021 2022 2023 2024 2025 |
hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
TclGetString(objv[i])));
| | | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 |
hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", (char *)NULL);
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
}
}
Tcl_SetHashValue(hashEntry, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]);
}
|
| ︙ | ︙ | |||
2104 2105 2106 2107 2108 2109 2110 |
TclNewObj(operandObj);
if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
Tcl_DecrRefCount(operandObj);
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"assembly code may not contain substitutions", -1));
| | | 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 |
TclNewObj(operandObj);
if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
Tcl_DecrRefCount(operandObj);
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"assembly code may not contain substitutions", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", (char *)NULL);
}
return TCL_ERROR;
}
*tokenPtrPtr = TokenAfter(*tokenPtrPtr);
Tcl_IncrRefCount(operandObj);
*operandObjPtr = operandObj;
return TCL_OK;
|
| ︙ | ︙ | |||
2315 2316 2317 2318 2319 2320 2321 |
const char* varNameStr;
Tcl_Size varNameLen;
Tcl_Size localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return TCL_INDEX_NONE;
}
| | | | 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 |
const char* varNameStr;
Tcl_Size varNameLen;
Tcl_Size localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return TCL_INDEX_NONE;
}
varNameStr = TclGetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
return TCL_INDEX_NONE;
}
localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
Tcl_DecrRefCount(varNameObj);
if (localVar < 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use this instruction to create a variable"
" in a non-proc context", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", (char *)NULL);
}
return TCL_INDEX_NONE;
}
*tokenPtrPtr = TokenAfter(tokenPtr);
return localVar;
}
|
| ︙ | ︙ | |||
2362 2363 2364 2365 2366 2367 2368 |
{
const char* p;
for (p = name; p+2 < name+nameLen; p++) {
if ((*p == ':') && (p[1] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable \"%s\" is not local", name));
| | | 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 |
{
const char* p;
for (p = name; p+2 < name+nameLen; p++) {
if ((*p == ':') && (p[1] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable \"%s\" is not local", name));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, (char *)NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2398 2399 2400 2401 2402 2403 2404 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0 || value > 0xFF) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
| | | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0 || value > 0xFF) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value > 0x7F || value < -0x80) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
| | | 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value > 0x7F || value < -0x80) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2466 2467 2468 2469 2470 2471 2472 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0) {
result = Tcl_NewStringObj("operand must be nonnegative", -1);
Tcl_SetObjResult(interp, result);
| | | 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0) {
result = Tcl_NewStringObj("operand must be nonnegative", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2499 2500 2501 2502 2503 2504 2505 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value <= 0) {
result = Tcl_NewStringObj("operand must be positive", -1);
Tcl_SetObjResult(interp, result);
| | | 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 |
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value <= 0) {
result = Tcl_NewStringObj("operand must be positive", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2551 2552 2553 2554 2555 2556 2557 |
* This is a duplicate label.
*/
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate definition of label \"%s\"", labelName));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName,
| | | 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 |
* This is a duplicate label.
*/
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate definition of label \"%s\"", labelName));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName,
(char *)NULL);
}
return TCL_ERROR;
}
/*
* This is the first appearance of the label in the code.
*/
|
| ︙ | ︙ | |||
2952 2953 2954 2955 2956 2957 2958 |
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"undefined label \"%s\"", TclGetString(jumpTarget)));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
| | | 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 |
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"undefined label \"%s\"", TclGetString(jumpTarget)));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
TclGetString(jumpTarget), (char *)NULL);
Tcl_SetErrorLine(interp, bbPtr->jumpLine);
}
}
/*
*-----------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3237 3238 3239 3240 3241 3242 3243 |
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" instruction may not appear in "
"a context where an exception has been "
"caught and not disposed of.",
tclInstructionTable[opcode].name));
| | | 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 |
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" instruction may not appear in "
"a context where an exception has been "
"caught and not disposed of.",
tclInstructionTable[opcode].name));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", (char *)NULL);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
}
return TCL_ERROR;
}
offset += tclInstructionTable[opcode].numBytes;
}
return TCL_OK;
|
| ︙ | ︙ | |||
3417 3418 3419 3420 3421 3422 3423 | "inconsistent stack depths on two execution paths", -1)); /* * TODO - add execution trace of both paths */ Tcl_SetErrorLine(interp, blockPtr->startLine); | | | 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 |
"inconsistent stack depths on two execution paths", -1));
/*
* TODO - add execution trace of both paths
*/
Tcl_SetErrorLine(interp, blockPtr->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (char *)NULL);
}
return TCL_ERROR;
}
/*
* If the block is not already visited, set the 'predecessor' link to
* indicate how control got to it. Set the initial stack depth to the
|
| ︙ | ︙ | |||
3440 3441 3442 3443 3444 3445 3446 |
* Calculate minimum stack depth, and flag an error if the block
* underflows the stack.
*/
if (initialStackDepth + blockPtr->minStackDepth < 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1));
| | | | 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 |
* Calculate minimum stack depth, and flag an error if the block
* underflows the stack.
*/
if (initialStackDepth + blockPtr->minStackDepth < 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (char *)NULL);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
Tcl_SetErrorLine(interp, blockPtr->startLine);
}
return TCL_ERROR;
}
/*
* Make sure that the block doesn't try to pop below the stack level of an
* enclosing catch.
*/
if (blockPtr->enclosingCatch != 0 &&
initialStackDepth + blockPtr->minStackDepth
< (blockPtr->enclosingCatch->initialStackDepth
+ blockPtr->enclosingCatch->finalStackDepth)) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"code pops stack below level of enclosing catch", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", (char *)NULL);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
Tcl_SetErrorLine(interp, blockPtr->startLine);
}
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3587 3588 3589 3590 3591 3592 3593 |
*/
if (depth != 1) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"stack is unbalanced on exit from the code (depth=%d)",
depth));
| | | 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 |
*/
if (depth != 1) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"stack is unbalanced on exit from the code (depth=%d)",
depth));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (char *)NULL);
}
return TCL_ERROR;
}
/*
* Record stack usage.
*/
|
| ︙ | ︙ | |||
3732 3733 3734 3735 3736 3737 3738 |
bbPtr->enclosingCatch = enclosing;
} else if (bbPtr->enclosingCatch != enclosing) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"execution reaches an instruction in inconsistent "
"exception contexts", -1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
| | | 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 |
bbPtr->enclosingCatch = enclosing;
} else if (bbPtr->enclosingCatch != enclosing) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"execution reaches an instruction in inconsistent "
"exception contexts", -1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", (char *)NULL);
}
return TCL_ERROR;
}
if (state > bbPtr->catchState) {
bbPtr->catchState = state;
changed = 1;
}
|
| ︙ | ︙ | |||
3791 3792 3793 3794 3795 3796 3797 |
*/
if (enclosing == NULL) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"endCatch without a corresponding beginCatch", -1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
| | | 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 |
*/
if (enclosing == NULL) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"endCatch without a corresponding beginCatch", -1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", (char *)NULL);
}
return TCL_ERROR;
}
fallThruEnclosing = enclosing->enclosingCatch;
fallThruState = enclosing->catchState;
--catchDepth;
}
|
| ︙ | ︙ | |||
3867 3868 3869 3870 3871 3872 3873 |
if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"catch still active on exit from assembly code", -1));
Tcl_SetErrorLine(interp,
assemEnvPtr->curr_bb->enclosingCatch->startLine);
| | | 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 |
if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"catch still active on exit from assembly code", -1));
Tcl_SetErrorLine(interp,
assemEnvPtr->curr_bb->enclosingCatch->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", (char *)NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | * double layout and a 32-bit 'int' type). */ #define TCL_FPCLASSIFY_MODE 2 #endif /* !fpclassify */ /* actually there is no fallback to builtin fpclassify */ #endif /* !TCL_FPCLASSIFY_MODE */ | < | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | * double layout and a 32-bit 'int' type). */ #define TCL_FPCLASSIFY_MODE 2 #endif /* !fpclassify */ /* actually there is no fallback to builtin fpclassify */ #endif /* !TCL_FPCLASSIFY_MODE */ /* * Bug 7371b6270b: to check C call stack depth, prefer an approach which is * compatible with AddressSanitizer (ASan) use-after-return detection. */ #if defined(_MSC_VER) && defined(HAVE_INTRIN_H) #include <intrin.h> /* for _AddressOfReturnAddress() */ |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
#define __has_builtin(x) 0 /* for non-clang compilers */
#endif
void *
TclGetCStackPtr(void)
{
#if defined( __GNUC__ ) || __has_builtin(__builtin_frame_address)
| | | | | | | | | | | 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 |
#define __has_builtin(x) 0 /* for non-clang compilers */
#endif
void *
TclGetCStackPtr(void)
{
#if defined( __GNUC__ ) || __has_builtin(__builtin_frame_address)
return __builtin_frame_address(0);
#elif defined(_MSC_VER) && defined(HAVE_INTRIN_H)
return _AddressOfReturnAddress();
#else
ptrdiff_t unused = 0;
/*
* LLVM recommends using volatile:
* https://github.com/llvm/llvm-project/blob/llvmorg-10.0.0-rc1/clang/lib/Basic/Stack.cpp#L31
*/
ptrdiff_t *volatile stackLevel = &unused;
return (void *)stackLevel;
#endif
}
#define INTERP_STACK_INITIAL_SIZE 2000
#define CORO_STACK_INITIAL_SIZE 200
/*
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr
/*
* Static functions in this file:
*/
| | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr
/*
* Static functions in this file:
*/
static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
static int CancelEvalProc(void *clientData,
Tcl_Interp *interp, int code);
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
static void DeleteCoroutine(void *clientData);
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 | static Tcl_ObjCmdProc ExprBinaryFunc; static Tcl_ObjCmdProc ExprBoolFunc; static Tcl_ObjCmdProc ExprCeilFunc; static Tcl_ObjCmdProc ExprDoubleFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; | | | | | | | | | | | < | | | | | | | | | | | | | | > > > | > | > < | | | | | | | 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 |
static Tcl_ObjCmdProc ExprBinaryFunc;
static Tcl_ObjCmdProc ExprBoolFunc;
static Tcl_ObjCmdProc ExprCeilFunc;
static Tcl_ObjCmdProc ExprDoubleFunc;
static Tcl_ObjCmdProc ExprFloorFunc;
static Tcl_ObjCmdProc ExprIntFunc;
static Tcl_ObjCmdProc ExprIsqrtFunc;
static Tcl_ObjCmdProc ExprIsFiniteFunc;
static Tcl_ObjCmdProc ExprIsInfinityFunc;
static Tcl_ObjCmdProc ExprIsNaNFunc;
static Tcl_ObjCmdProc ExprIsNormalFunc;
static Tcl_ObjCmdProc ExprIsSubnormalFunc;
static Tcl_ObjCmdProc ExprIsUnorderedFunc;
static Tcl_ObjCmdProc ExprMaxFunc;
static Tcl_ObjCmdProc ExprMinFunc;
static Tcl_ObjCmdProc ExprRandFunc;
static Tcl_ObjCmdProc ExprRoundFunc;
static Tcl_ObjCmdProc ExprSqrtFunc;
static Tcl_ObjCmdProc ExprSrandFunc;
static Tcl_ObjCmdProc ExprUnaryFunc;
static Tcl_ObjCmdProc ExprWideFunc;
static Tcl_ObjCmdProc FloatClassifyObjCmd;
static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static Tcl_NRPostProc NRCommand;
static void ProcessUnexpectedResult(Tcl_Interp *interp,
int returnCode);
static int RewindCoroutine(CoroutineData *corPtr, int result);
static void TEOV_SwitchVarFrame(Tcl_Interp *interp);
static void TEOV_PushExceptionHandlers(Tcl_Interp *interp,
Tcl_Size objc, Tcl_Obj *const objv[], int flags);
static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp,
Tcl_Obj *namePtr, Namespace *lookupNsPtr);
static int TEOV_NotFound(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static int TEOV_RunEnterTraces(Tcl_Interp *interp,
Command **cmdPtrPtr, Tcl_Obj *commandPtr, Tcl_Size objc,
Tcl_Obj *const objv[]);
static Tcl_NRPostProc RewindCoroutineCallback;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
static Tcl_NRPostProc TEOEx_ListCallback;
static Tcl_NRPostProc TEOV_Error;
static Tcl_NRPostProc TEOV_Exception;
static Tcl_NRPostProc TEOV_NotFoundCallback;
static Tcl_NRPostProc TEOV_RestoreVarFrame;
static Tcl_NRPostProc TEOV_RunLeaveTraces;
static Tcl_NRPostProc EvalObjvCore;
static Tcl_NRPostProc Dispatch;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;
static Tcl_ObjCmdProc TclNRCoroInjectObjCmd;
static Tcl_ObjCmdProc TclNRCoroProbeObjCmd;
static Tcl_NRPostProc InjectHandler;
static Tcl_NRPostProc InjectHandlerPostCall;
MODULE_SCOPE const TclStubs tclStubs;
/*
* Magical counts for the number of arguments accepted by a coroutine command
* after particular kinds of [yield].
*/
#define CORO_ACTIVATE_YIELD NULL
#define CORO_ACTIVATE_YIELDM INT2PTR(1)
#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1)
#define COROUTINE_ARGUMENTS_ARBITRARY (-2)
/*
* The following structure define the commands in the Tcl core.
*/
typedef struct {
const char *name; /* Name of object-based command. */
Tcl_ObjCmdProc *objProc; /* Object-based function for command. */
CompileProc *compileProc; /* Function called to compile command. */
Tcl_ObjCmdProc *nreProc; /* NR-based function for command */
int flags; /* Various flag bits, as defined below. */
} CmdInfo;
#define CMD_IS_SAFE 1 /* Whether this command is part of the set of
* commands present by default in a safe
* interpreter. */
/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle
* expansion for itself rather than needing the generic layer to take care of
* it for it. Defined in tclInt.h. */
/*
* The following struct states that the command it talks about (a subcommand
* of one of Tcl's built-in ensembles) is unsafe and must be hidden when an
* interpreter is made safe. (TclHideUnsafeCommands accesses an array of these
* structs.) Alas, we can't sensibly just store the information directly in
* the commands.
*/
typedef struct {
const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for
* the end of the list of commands to hide. */
const char *commandName; /* The name of the command within the
* ensemble. If this is NULL, we want to also
* make the overall command be hidden, an ugly
* hack because it is expected by security
* policies in the wild. */
} UnsafeEnsembleInfo;
/*
* The built-in commands, and the functions that implement them:
*/
static int
procObjCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return Tcl_ProcObjCmd(clientData, interp, objc, objv);
}
static const CmdInfo builtInCmds[] = {
/*
* Commands in the generic core.
*/
{"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},
{"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
{"proc", procObjCmd, NULL, NULL, CMD_IS_SAFE},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
{"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE},
{"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE},
|
| ︙ | ︙ | |||
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 |
{"file", "attributes"},
{"file", "copy"},
{"file", "delete"},
{"file", "dirname"},
{"file", "executable"},
{"file", "exists"},
{"file", "extension"},
{"file", "isdirectory"},
{"file", "isfile"},
{"file", "link"},
{"file", "lstat"},
{"file", "mtime"},
{"file", "mkdir"},
{"file", "nativename"},
{"file", "normalize"},
{"file", "owned"},
{"file", "readable"},
{"file", "readlink"},
{"file", "rename"},
{"file", "rootname"},
{"file", "size"},
{"file", "stat"},
{"file", "tail"},
{"file", "tempdir"},
{"file", "tempfile"},
{"file", "type"},
{"file", "volumes"},
{"file", "writable"},
/* [info] has two unsafe commands */
{"info", "cmdtype"},
{"info", "nameofexecutable"},
/* [tcl::process] has ONLY unsafe commands! */
{"process", "list"},
{"process", "status"},
{"process", "purge"},
{"process", "autopurge"},
| > > > > > > | > > > > | > > > > > | | | | | | | | | | | | | | | | | 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 |
{"file", "attributes"},
{"file", "copy"},
{"file", "delete"},
{"file", "dirname"},
{"file", "executable"},
{"file", "exists"},
{"file", "extension"},
{"file", "home"},
{"file", "isdirectory"},
{"file", "isfile"},
{"file", "link"},
{"file", "lstat"},
{"file", "mtime"},
{"file", "mkdir"},
{"file", "nativename"},
{"file", "normalize"},
{"file", "owned"},
{"file", "readable"},
{"file", "readlink"},
{"file", "rename"},
{"file", "rootname"},
{"file", "size"},
{"file", "stat"},
{"file", "tail"},
{"file", "tempdir"},
{"file", "tempfile"},
{"file", "tildeexpand"},
{"file", "type"},
{"file", "volumes"},
{"file", "writable"},
/* [info] has two unsafe commands */
{"info", "cmdtype"},
{"info", "nameofexecutable"},
/* [tcl::process] has ONLY unsafe commands! */
{"process", "list"},
{"process", "status"},
{"process", "purge"},
{"process", "autopurge"},
/*
* [zipfs] perhaps has some safe commands. But like file make it inaccessible
* until they are analyzed to be safe.
*/
{"zipfs", NULL},
{"zipfs", "canonical"},
{"zipfs", "exists"},
{"zipfs", "info"},
{"zipfs", "list"},
{"zipfs", "lmkimg"},
{"zipfs", "lmkzip"},
{"zipfs", "mkimg"},
{"zipfs", "mkkey"},
{"zipfs", "mkzip"},
{"zipfs", "mount"},
{"zipfs", "mountdata"},
{"zipfs", "root"},
{"zipfs", "unmount"},
{NULL, NULL}
};
/*
* Math functions. All are safe.
*/
typedef double (BuiltinUnaryFunc)(double x);
typedef double (BuiltinBinaryFunc)(double x, double y);
#define BINARY_TYPECAST(fn) \
(BuiltinUnaryFunc *)(void *)(BuiltinBinaryFunc *) fn
typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
BuiltinUnaryFunc *fn; /* Real function pointer */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "abs", ExprAbsFunc, NULL },
{ "acos", ExprUnaryFunc, acos },
{ "asin", ExprUnaryFunc, asin },
{ "atan", ExprUnaryFunc, atan },
{ "atan2", ExprBinaryFunc, BINARY_TYPECAST(atan2) },
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
{ "cos", ExprUnaryFunc, cos },
{ "cosh", ExprUnaryFunc, cosh },
{ "double", ExprDoubleFunc, NULL },
{ "entier", ExprIntFunc, NULL },
{ "exp", ExprUnaryFunc, exp },
{ "floor", ExprFloorFunc, NULL },
{ "fmod", ExprBinaryFunc, BINARY_TYPECAST(fmod) },
{ "hypot", ExprBinaryFunc, BINARY_TYPECAST(hypot) },
{ "int", ExprIntFunc, NULL },
{ "isfinite", ExprIsFiniteFunc, NULL },
{ "isinf", ExprIsInfinityFunc, NULL },
{ "isnan", ExprIsNaNFunc, NULL },
{ "isnormal", ExprIsNormalFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
{ "issubnormal", ExprIsSubnormalFunc, NULL, },
{ "isunordered", ExprIsUnorderedFunc, NULL, },
{ "log", ExprUnaryFunc, log },
{ "log10", ExprUnaryFunc, log10 },
{ "max", ExprMaxFunc, NULL },
{ "min", ExprMinFunc, NULL },
{ "pow", ExprBinaryFunc, BINARY_TYPECAST(pow) },
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
{ "sin", ExprUnaryFunc, sin },
{ "sinh", ExprUnaryFunc, sinh },
{ "sqrt", ExprSqrtFunc, NULL },
{ "srand", ExprSrandFunc, NULL },
{ "tan", ExprUnaryFunc, tan },
{ "tanh", ExprUnaryFunc, tanh },
{ "wide", ExprWideFunc, NULL },
{ NULL, NULL, NULL }
};
/*
* TIP#174's math operators. All are safe.
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
Tcl_DeleteHashTable(&cancelTable);
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
Tcl_MutexLock(&commandTypeLock);
if (commandTypeInit) {
| | | | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 |
Tcl_DeleteHashTable(&cancelTable);
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
Tcl_MutexLock(&commandTypeLock);
if (commandTypeInit) {
Tcl_DeleteHashTable(&commandTypeTable);
commandTypeInit = 0;
}
Tcl_MutexUnlock(&commandTypeLock);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 656 657 658 659 |
static int
buildInfoObjCmd2(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?option?");
return TCL_ERROR;
}
| > > > > > > > > > > > > > > > | > > > | | < < < | < < | | | > > > | | | | | | > | | > > | | | | | | | | < | < | | | | | > | < | < > | > > > | | | > | < < | | | | | | > > > > > > > | < > > > | > > | > > > > | < | < < < < < < < | | 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 |
static int
buildInfoObjCmd2(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *buildData = (const char *) clientData;
char buf[80];
const char *arg, *p, *q;
Tcl_Size len;
int idx;
static const char *identifiers[] = {
"commit", "compiler", "patchlevel", "version", NULL
};
enum Identifiers {
ID_COMMIT, ID_COMPILER, ID_PATCHLEVEL, ID_VERSION, ID_OTHER
};
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?option?");
return TCL_ERROR;
} else if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(buildData, TCL_INDEX_NONE));
return TCL_OK;
}
/*
* Query for a specific piece of build info
*/
if (Tcl_GetIndexFromObj(NULL, objv[1], identifiers, NULL, TCL_EXACT,
&idx) != TCL_OK) {
idx = ID_OTHER;
}
switch (idx) {
case ID_PATCHLEVEL:
if ((p = strchr(buildData, '+')) != NULL) {
memcpy(buf, buildData, p - buildData);
buf[p - buildData] = '\0';
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
}
return TCL_OK;
case ID_VERSION:
if ((p = strchr(buildData, '.')) != NULL) {
const char *r = strchr(p++, '+');
q = strchr(p, '.');
p = (q < r) ? q : r;
}
if (p != NULL) {
memcpy(buf, buildData, p - buildData);
buf[p - buildData] = '\0';
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
}
return TCL_OK;
case ID_COMMIT:
if ((p = strchr(buildData, '+')) != NULL) {
if ((q = strchr(p++, '.')) != NULL) {
memcpy(buf, p, q - p);
buf[q - p] = '\0';
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, TCL_INDEX_NONE));
}
}
return TCL_OK;
case ID_COMPILER:
for (p = strchr(buildData, '.'); p++; p = strchr(p, '.')) {
/*
* Does the word begin with one of the standard prefixes?
*/
if (!strncmp(p, "clang-", 6)
|| !strncmp(p, "gcc-", 4)
|| !strncmp(p, "icc-", 4)
|| !strncmp(p, "msvc-", 5)) {
if ((q = strchr(p, '.')) != NULL) {
memcpy(buf, p, q - p);
buf[q - p] = '\0';
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, TCL_INDEX_NONE));
}
return TCL_OK;
}
}
break;
default: /* Boolean test for other identifiers' presence */
arg = TclGetStringFromObj(objv[1], &len);
for (p = strchr(buildData, '.'); p++; p = strchr(p, '.')) {
if (!strncmp(p, arg, len)
&& ((p[len] == '.') || (p[len] == '-') || (p[len] == '\0'))) {
if (p[len] == '-') {
p += len;
q = strchr(++p, '.');
if (!q) {
q = p + strlen(p);
}
memcpy(buf, p, q - p);
buf[q - p] = '\0';
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
} else {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
}
return TCL_OK;
}
}
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
return TCL_OK;
}
static int
buildInfoObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
}
Tcl_MutexUnlock(&cancelLock);
}
#undef TclObjInterpProc
if (commandTypeInit == 0) {
| | | | | | | | | | | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 |
}
Tcl_MutexUnlock(&cancelLock);
}
#undef TclObjInterpProc
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclChildObjCmd, "interp");
TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
}
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
* object type table and other object management code.
*/
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
#ifdef TCL_INTERP_DEBUG_FRAME
iPtr->flags |= INTERP_DEBUG_FRAME;
#else
if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
| | | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
#ifdef TCL_INTERP_DEBUG_FRAME
iPtr->flags |= INTERP_DEBUG_FRAME;
#else
if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
iPtr->flags |= INTERP_DEBUG_FRAME;
}
#endif
/*
* Initialise the tables for variable traces and searches *before*
* creating the global ns - so that the trace on errorInfo can be
* recorded.
|
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | cmdPtr->proc = NULL; cmdPtr->clientData = cmdPtr; cmdPtr->objProc = cmdInfoPtr->objProc; cmdPtr->objClientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; cmdPtr->flags = 0; | | | | | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 |
cmdPtr->proc = NULL;
cmdPtr->clientData = cmdPtr;
cmdPtr->objProc = cmdInfoPtr->objProc;
cmdPtr->objClientData = NULL;
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
cmdPtr->flags = 0;
if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) {
cmdPtr->flags |= CMD_COMPILES_EXPANDED;
}
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
cmdPtr->nreProc = cmdInfoPtr->nreProc;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 |
Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode",
Tcl_DisassembleObjCmd, INT2PTR(1), NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
Tcl_RepresentationCmd, NULL, NULL);
/* Adding the bytecode assembler command */
cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
| | | | | > > | | < | 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 |
Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode",
Tcl_DisassembleObjCmd, INT2PTR(1), NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
Tcl_RepresentationCmd, NULL, NULL);
/* Adding the bytecode assembler command */
cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
"::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
/* Coroutine monkeybusiness */
Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
CoroTypeObjCmd, NULL, NULL);
/* Load and intialize ICU */
Tcl_CreateObjCommand(interp, "::tcl::unsupported::loadIcu",
TclLoadIcuObjCmd, NULL, NULL);
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
if (nsPtr) {
Tcl_Export(interp, nsPtr, "*", 1);
}
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
*/
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
|
| ︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 |
if (nsPtr == NULL) {
Tcl_Panic("Can't create math function namespace");
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
| | | | 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 |
if (nsPtr == NULL) {
Tcl_Panic("Can't create math function namespace");
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
strcpy(mathFuncName + MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
builtinFuncPtr->objCmdProc, (void *)builtinFuncPtr->fn, NULL);
Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0);
}
/*
* Register the mathematical "operator" commands. [TIP #174]
*/
nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("cannot create math operator namespace");
}
Tcl_Export(interp, nsPtr, "*", 1);
#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)Tcl_Alloc(sizeof(TclOpCmdClientData));
|
| ︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 |
Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
if (TclOOInit(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
| < < < < < < | < < < < | | | | | | | | | | | | | | | | | | | | | 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 |
Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
if (TclOOInit(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
if (TclZlibInit(interp) != TCL_OK || TclZipfs_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
TOP_CB(iPtr) = NULL;
return interp;
}
static void
DeleteOpCmdClientData(
void *clientData)
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
Tcl_Free(occdPtr);
}
/*
* ---------------------------------------------------------------------
*
* TclRegisterCommandTypeName, TclGetCommandTypeName --
*
* Command type registration and lookup mechanism. Everything is keyed by
* the Tcl_ObjCmdProc for the command, and that is used as the *key* into
* the hash table that maps to constant strings that are names. (It is
* recommended that those names be ASCII.)
*
* ---------------------------------------------------------------------
*/
void
TclRegisterCommandTypeName(
Tcl_ObjCmdProc *implementationProc,
const char *nameStr)
{
Tcl_HashEntry *hPtr;
Tcl_MutexLock(&commandTypeLock);
if (commandTypeInit == 0) {
Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
commandTypeInit = 1;
}
if (nameStr != NULL) {
int isNew;
hPtr = Tcl_CreateHashEntry(&commandTypeTable,
implementationProc, &isNew);
Tcl_SetHashValue(hPtr, (void *) nameStr);
} else {
hPtr = Tcl_FindHashEntry(&commandTypeTable,
implementationProc);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
}
Tcl_MutexUnlock(&commandTypeLock);
}
const char *
TclGetCommandTypeName(
Tcl_Command command)
{
Command *cmdPtr = (Command *) command;
Tcl_ObjCmdProc *procPtr = cmdPtr->objProc;
const char *name = "native";
if (procPtr == NULL) {
procPtr = cmdPtr->nreProc;
}
Tcl_MutexLock(&commandTypeLock);
if (commandTypeInit) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr);
if (hPtr && Tcl_GetHashValue(hPtr)) {
name = (const char *) Tcl_GetHashValue(hPtr);
}
}
Tcl_MutexUnlock(&commandTypeLock);
return name;
}
/*
|
| ︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 |
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
for (unsafePtr = unsafeEnsembleCommands;
| | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 |
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
for (unsafePtr = unsafeEnsembleCommands;
unsafePtr->ensembleNsName; unsafePtr++) {
if (unsafePtr->commandName) {
/*
* Hide an ensemble subcommand.
*/
Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s",
unsafePtr->ensembleNsName, unsafePtr->commandName);
Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s",
unsafePtr->ensembleNsName, unsafePtr->commandName);
#define INTERIM_HACK_NAME "___tmp"
if (TclRenameCommand(interp, TclGetString(cmdName),
INTERIM_HACK_NAME) != TCL_OK
|| Tcl_HideCommand(interp, INTERIM_HACK_NAME,
TclGetString(hideName)) != TCL_OK) {
Tcl_Panic("problem making '%s %s' safe: %s",
unsafePtr->ensembleNsName, unsafePtr->commandName,
Tcl_GetStringResult(interp));
}
Tcl_CreateObjCommand(interp, TclGetString(cmdName),
BadEnsembleSubcommand, (void *)unsafePtr, NULL);
TclDecrRefCount(cmdName);
TclDecrRefCount(hideName);
} else {
/*
* Hide an ensemble main command (for compatibility).
*/
if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName,
unsafePtr->ensembleNsName) != TCL_OK) {
Tcl_Panic("problem making '%s' safe: %s",
unsafePtr->ensembleNsName,
Tcl_GetStringResult(interp));
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1484 1485 1486 1487 1488 1489 1490 |
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /* objv */)
{
const UnsafeEnsembleInfo *infoPtr = (const UnsafeEnsembleInfo *)clientData;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 |
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /* objv */)
{
const UnsafeEnsembleInfo *infoPtr = (const UnsafeEnsembleInfo *)clientData;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"not allowed to invoke subcommand %s of %s",
infoPtr->commandName, infoPtr->ensembleNsName));
Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", (char *)NULL);
return TCL_ERROR;
}
/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
|
| ︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 |
*/
void
Tcl_CallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
| | | | | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 |
*/
void
Tcl_CallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr = (int *)
Tcl_GetThreadData(&assocDataCounterKey, sizeof(int));
int isNew;
char buffer[32 + TCL_INTEGER_SPACE];
AssocData *dPtr = (AssocData *)Tcl_Alloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
snprintf(buffer, sizeof(buffer), "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
*/
void
Tcl_DontCallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
| | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 |
*/
void
Tcl_DontCallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTablePtr;
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
AssocData *dPtr;
|
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 |
void
Tcl_SetAssocData(
Tcl_Interp *interp, /* Interpreter to associate with. */
const char *name, /* Name for association. */
Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to
* be deleted. */
| | | 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 |
void
Tcl_SetAssocData(
Tcl_Interp *interp, /* Interpreter to associate with. */
const char *name, /* Name for association. */
Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to
* be deleted. */
void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (iPtr->assocData == NULL) {
|
| ︙ | ︙ | |||
1929 1930 1931 1932 1933 1934 1935 |
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
Tcl_Free(hTablePtr);
}
| < > < | 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 |
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
Tcl_Free(hTablePtr);
}
if (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
/*
* Invoke deletion callbacks; note that a callback can create new
* callbacks, so we iterate.
*/
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
Tcl_Free(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
Tcl_Free(hTablePtr);
iPtr->assocData = NULL;
}
|
| ︙ | ︙ | |||
2181 2182 2183 2184 2185 2186 2187 |
* the source, in order to avoid potential confusion, lets prevent "::" in
* the token too. - dl
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use namespace qualifiers in hidden command"
| | | | 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 |
* the source, in order to avoid potential confusion, lets prevent "::" in
* the token too. - dl
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use namespace qualifiers in hidden command"
" token (rename)", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (char *)NULL);
return TCL_ERROR;
}
/*
* Find the command to hide. An error is returned if cmdName can't be
* found. Look up the command only from the global namespace. Full path of
* the command must be given if using namespaces.
|
| ︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 |
/*
* Check that the command is really in global namespace
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | | 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 |
/*
* Check that the command is really in global namespace
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only hide global namespace commands (use rename then hide)",
TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (char *)NULL);
return TCL_ERROR;
}
/*
* Initialize the hidden command table if necessary.
*/
|
| ︙ | ︙ | |||
2231 2232 2233 2234 2235 2236 2237 |
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
* exists.
*/
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 |
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
* exists.
*/
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"hidden command named \"%s\" already exists",
hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", (char *)NULL);
return TCL_ERROR;
}
/*
* NB: This code is currently 'like' a rename to a special separate name
* table. Changes here and in TclRenameCommand must be kept in synch until
* the common parts are actually factorized out.
|
| ︙ | ︙ | |||
2335 2336 2337 2338 2339 2340 2341 |
* Check that we have a regular name for the command (that the user is not
* trying to do an expose and a rename (to another namespace) at the same
* time).
*/
if (strstr(cmdName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | | | | | | | | 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
* Check that we have a regular name for the command (that the user is not
* trying to do an expose and a rename (to another namespace) at the same
* time).
*/
if (strstr(cmdName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot expose to a namespace (use expose to toplevel, then rename)",
TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (char *)NULL);
return TCL_ERROR;
}
/*
* Get the command from the hidden command table:
*/
hPtr = NULL;
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr != NULL) {
hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
}
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, (char *)NULL);
return TCL_ERROR;
}
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Check that we have a true global namespace command (enforced by
* Tcl_HideCommand but let's double check. (If it was not, we would not
* really know how to handle it).
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
/*
* This case is theoretically impossible, we might rather Tcl_Panic
* than 'nicely' erroring out ?
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"trying to expose a non-global command namespace command",
TCL_INDEX_NONE));
return TCL_ERROR;
}
/*
* This is the global table.
*/
nsPtr = cmdPtr->nsPtr;
/*
* It is an error to overwrite an existing exposed command as a result of
* exposing a previously hidden command.
*/
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"exposed command \"%s\" already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", (char *)NULL);
return TCL_ERROR;
}
/*
* Command resolvers (per-interp, per-namespace) might have resolved to a
* command for the given namespace scope with this command not being
* registered with the namespace's command table. During BC compilation,
|
| ︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 |
Tcl_Interp *interp, /* Token for command interpreter returned by a
* previous call to Tcl_CreateInterp. */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_CmdProc *proc, /* Function to associate with cmdName. */
| | | 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 |
Tcl_Interp *interp, /* Token for command interpreter returned by a
* previous call to Tcl_CreateInterp. */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_CmdProc *proc, /* Function to associate with cmdName. */
void *clientData, /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
Interp *iPtr = (Interp *) interp;
ImportRef *oldRefPtr = NULL;
Namespace *nsPtr;
|
| ︙ | ︙ | |||
2520 2521 2522 2523 2524 2525 2526 |
* If the command name we seek to create already exists, we need to
* delete that first. That can be tricky in the presence of traces.
* Loop until we no longer find an existing command in the way, or
* until we've deleted one command and that didn't finish the job.
*/
while (1) {
| | | | | | | | | | | | | 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 |
* If the command name we seek to create already exists, we need to
* delete that first. That can be tricky in the presence of traces.
* Loop until we no longer find an existing command in the way, or
* until we've deleted one command and that didn't finish the job.
*/
while (1) {
/*
* Determine where the command should reside. If its name contains
* namespace qualifiers, we put it in the specified namespace;
* otherwise, we always put it in the global namespace.
*/
if (strstr(cmdName, "::") != NULL) {
Namespace *dummy1, *dummy2;
TclGetNamespaceForQualName(interp, cmdName, NULL,
TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
if ((nsPtr == NULL) || (tail == NULL)) {
return (Tcl_Command) NULL;
}
} else {
nsPtr = iPtr->globalNsPtr;
tail = cmdName;
}
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
if (isNew || deleted) {
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Be careful to preserve any existing import links so we can restore
* them down below. That way, you can redefine a command and its
* import status will remain intact.
|
| ︙ | ︙ | |||
2684 2685 2686 2687 2688 2689 2690 |
Tcl_ObjCmdProc2 *proc;
void *clientData; /* Arbitrary value to pass to proc function. */
Tcl_CmdDeleteProc *deleteProc;
void *deleteData; /* Arbitrary value to pass to deleteProc function. */
Tcl_ObjCmdProc2 *nreProc;
} CmdWrapperInfo;
| | > | | > | > > | | | < | 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 |
Tcl_ObjCmdProc2 *proc;
void *clientData; /* Arbitrary value to pass to proc function. */
Tcl_CmdDeleteProc *deleteProc;
void *deleteData; /* Arbitrary value to pass to deleteProc function. */
Tcl_ObjCmdProc2 *nreProc;
} CmdWrapperInfo;
static int
cmdWrapperProc(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj * const *objv)
{
CmdWrapperInfo *info = (CmdWrapperInfo *) clientData;
if (objc < 0) {
objc = -1;
}
return info->proc(info->clientData, interp, objc, objv);
}
static void
cmdWrapperDeleteProc(
void *clientData)
{
CmdWrapperInfo *info = (CmdWrapperInfo *) clientData;
clientData = info->deleteData;
Tcl_CmdDeleteProc *deleteProc = info->deleteProc;
Tcl_Free(info);
if (deleteProc != NULL) {
deleteProc(clientData);
}
}
Tcl_Command
Tcl_CreateObjCommand2(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
* name. */
void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo));
info->proc = proc;
info->clientData = clientData;
info->deleteProc = deleteProc;
info->deleteData = clientData;
|
| ︙ | ︙ | |||
2746 2747 2748 2749 2750 2751 2752 |
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
| | | < | | | 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 |
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
Interp *iPtr = (Interp *)interp;
Namespace *nsPtr;
const char *tail;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Don't create any new commands;
* it's not safe to muck with the interpreter anymore.
*/
return NULL;
}
/*
* Determine where the command should reside. If its name contains
* namespace qualifiers, we put it in the specified namespace;
* otherwise, we always put it in the global namespace.
*/
|
| ︙ | ︙ | |||
2792 2793 2794 2795 2796 2797 2798 |
proc, clientData, deleteProc);
}
Tcl_Command
TclCreateObjCommandInNs(
Tcl_Interp *interp,
const char *cmdName, /* Name of command, without any namespace
| | | | | 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 |
proc, clientData, deleteProc);
}
Tcl_Command
TclCreateObjCommandInNs(
Tcl_Interp *interp,
const char *cmdName, /* Name of command, without any namespace
* components. */
Tcl_Namespace *namesp, /* The namespace to create the command in */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
int deleted = 0, isNew = 0;
Command *cmdPtr;
|
| ︙ | ︙ | |||
2828 2829 2830 2831 2832 2833 2834 | * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; } /* | | | | | | | 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 |
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Command already exists; delete it. Be careful to preserve any
* existing import links so we can restore them down below. That way,
* you can redefine a command and its import status will remain
* intact.
*/
cmdPtr->refCount++;
if (cmdPtr->importRefPtr) {
cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
}
/*
* Make sure namespace doesn't get deallocated.
*/
cmdPtr->nsPtr->refCount++;
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
nsPtr = (Namespace *) TclEnsureNamespace(interp,
(Tcl_Namespace *) cmdPtr->nsPtr);
TclNsDecrRefCount(cmdPtr->nsPtr);
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
oldRefPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = NULL;
}
TclCleanupCommandMacro(cmdPtr);
|
| ︙ | ︙ | |||
3039 3040 3041 3042 3043 3044 3045 |
* found.
*/
cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 |
* found.
*/
cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't %s \"%s\": command doesn't exist",
((newName == NULL) || (*newName == '\0')) ? "delete" : "rename",
oldName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, (char *)NULL);
return TCL_ERROR;
}
/*
* If the new command name is NULL or empty, delete the command. Do this
* with Tcl_DeleteCommandFromToken, since we already have the command.
*/
|
| ︙ | ︙ | |||
3072 3073 3074 3075 3076 3077 3078 |
*/
TclGetNamespaceForQualName(interp, newName, NULL,
TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
if ((newNsPtr == NULL) || (newTail == NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | | | 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 |
*/
TclGetNamespaceForQualName(interp, newName, NULL,
TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
if ((newNsPtr == NULL) || (newTail == NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't rename to \"%s\": bad command name", newName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't rename to \"%s\": command already exists", newName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
"TARGET_EXISTS", (char *)NULL);
result = TCL_ERROR;
goto done;
}
/*
* Warning: any changes done in the code here are likely to be needed in
* Tcl_HideCommand code too (until the common parts are extracted out).
|
| ︙ | ︙ | |||
3152 3153 3154 3155 3156 3157 3158 |
* The trace function needs to get a fully qualified name for old and new
* commands [Tcl bug #651271], or else there's no way for the trace
* function to get the namespace from which the old command is being
* renamed!
*/
Tcl_DStringInit(&newFullName);
| | | | 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 |
* The trace function needs to get a fully qualified name for old and new
* commands [Tcl bug #651271], or else there's no way for the trace
* function to get the namespace from which the old command is being
* renamed!
*/
Tcl_DStringInit(&newFullName);
Tcl_DStringAppend(&newFullName, newNsPtr->fullName, TCL_INDEX_NONE);
if (newNsPtr != iPtr->globalNsPtr) {
TclDStringAppendLiteral(&newFullName, "::");
}
Tcl_DStringAppend(&newFullName, newTail, TCL_INDEX_NONE);
cmdPtr->refCount++;
CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
/*
* The new command name is okay, so remove the command from its current
|
| ︙ | ︙ | |||
3253 3254 3255 3256 3257 3258 3259 | * None. * *---------------------------------------------------------------------- */ static int invokeObj2Command( | | | > > | | | 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 |
* None.
*
*----------------------------------------------------------------------
*/
static int
invokeObj2Command(
void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
Command *cmdPtr = (Command *)clientData;
if (objc > INT_MAX) {
return TclCommandWordLimitError(interp, objc);
}
if (cmdPtr->objProc != NULL) {
result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
} else {
result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
cmdPtr->objClientData, objc, objv);
}
return result;
}
static int
cmdWrapper2Proc(
void *clientData,
Tcl_Interp *interp,
Tcl_Size objc,
Tcl_Obj *const objv[])
{
Command *cmdPtr = (Command *) clientData;
if (objc > INT_MAX) {
return TclCommandWordLimitError(interp, objc);
}
return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
}
int
|
| ︙ | ︙ | |||
3315 3316 3317 3318 3319 3320 3321 |
if (infoPtr->objProc != cmdPtr->objProc) {
cmdPtr->nreProc = NULL;
cmdPtr->objProc = infoPtr->objProc;
}
cmdPtr->objClientData = infoPtr->objClientData;
}
if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
| | | 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 |
if (infoPtr->objProc != cmdPtr->objProc) {
cmdPtr->nreProc = NULL;
cmdPtr->objProc = infoPtr->objProc;
}
cmdPtr->objClientData = infoPtr->objClientData;
}
if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
CmdWrapperInfo *info = (CmdWrapperInfo *) cmdPtr->deleteData;
if (infoPtr->objProc2 == NULL) {
info->proc = invokeObj2Command;
info->clientData = cmdPtr;
info->nreProc = NULL;
} else {
if (infoPtr->objProc2 != info->proc) {
info->nreProc = NULL;
|
| ︙ | ︙ | |||
3520 3521 3522 3523 3524 3525 3526 |
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
if (cmdPtr->nsPtr != NULL) {
| | | | 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 |
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
if (cmdPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, TCL_INDEX_NONE);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_AppendToObj(objPtr, "::", 2);
}
}
if (cmdPtr->hPtr != NULL) {
name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE);
}
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3651 3652 3653 3654 3655 3656 3657 |
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
/* CallCommandTraces() does not cmdPtr, that's
| | | 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 |
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
/* CallCommandTraces() does not cmdPtr, that's
* done just before Tcl_DeleteCommandFromToken() returns */
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
/*
* Now delete these traces.
*/
tracePtr = cmdPtr->tracePtr;
|
| ︙ | ︙ | |||
4028 4029 4030 4031 4032 4033 4034 |
/*
* If the interpreter has been deleted, return an error.
*/
if (iPtr->flags & DELETED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 |
/*
* If the interpreter has been deleted, return an error.
*/
if (iPtr->flags & DELETED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to call eval in deleted interpreter", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "IDELETE",
"attempt to call eval in deleted interpreter", (char *)NULL);
return TCL_ERROR;
}
if (iPtr->execEnvPtr->rewind) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4057 4058 4059 4060 4061 4062 4063 |
*/
if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 |
*/
if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"too many nested evaluations (infinite loop?)", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclResetCancellation --
|
| ︙ | ︙ | |||
4135 4136 4137 4138 4139 4140 4141 |
/*
* Has the current script in progress for this interpreter been canceled
* or is the stack being unwound due to the previous script cancellation?
*/
if (!TclCanceled(iPtr)) {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 |
/*
* Has the current script in progress for this interpreter been canceled
* or is the stack being unwound due to the previous script cancellation?
*/
if (!TclCanceled(iPtr)) {
return TCL_OK;
}
/*
* The CANCELED flag is a one-shot flag that is reset immediately upon
* being detected; however, if the TCL_CANCEL_UNWIND flag is set we will
* continue to report that the script in progress has been canceled
* thereby allowing the evaluation stack for the interp to be fully
* unwound.
*/
iPtr->flags &= ~CANCELED;
/*
* The CANCELED flag was detected and reset; however, if the caller
* specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR
* (indicating that the script in progress has been canceled) if the
* evaluation stack for the interp is being fully unwound.
*/
if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) {
return TCL_OK;
}
/*
* If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
* interp's result; otherwise, we leave it alone.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
const char *id, *message = NULL;
Tcl_Size length;
/*
* Setup errorCode variables so that we can differentiate between
* being canceled and unwound.
*/
if (iPtr->asyncCancelMsg != NULL) {
message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
if (iPtr->flags & TCL_CANCEL_UNWIND) {
id = "IUNWIND";
if (length == 0) {
message = "eval unwound";
}
} else {
id = "ICANCEL";
if (length == 0) {
message = "eval canceled";
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (char *)NULL);
}
/*
* Return TCL_ERROR to the caller (not necessarily just the Tcl core
* itself) that indicates further processing of the script or command in
* progress should halt gracefully and as soon as possible.
*/
|
| ︙ | ︙ | |||
4231 4232 4233 4234 4235 4236 4237 |
int
Tcl_CancelEval(
Tcl_Interp *interp, /* Interpreter in which to cancel the
* script. */
Tcl_Obj *resultObjPtr, /* The script cancellation error message or
* NULL for a default error message. */
| | | 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 |
int
Tcl_CancelEval(
Tcl_Interp *interp, /* Interpreter in which to cancel the
* script. */
Tcl_Obj *resultObjPtr, /* The script cancellation error message or
* NULL for a default error message. */
void *clientData, /* Passed to CancelEvalProc. */
int flags) /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
* supported. */
{
Tcl_HashEntry *hPtr;
CancelInfo *cancelInfo;
|
| ︙ | ︙ | |||
4273 4274 4275 4276 4277 4278 4279 |
* cancellation request. Currently, clientData is ignored. If the
* TCL_CANCEL_UNWIND flags bit is set, the script in progress is not
* allowed to catch the script cancellation because the evaluation stack
* for the interp is completely unwound.
*/
if (resultObjPtr != NULL) {
| | | | 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 |
* cancellation request. Currently, clientData is ignored. If the
* TCL_CANCEL_UNWIND flags bit is set, the script in progress is not
* allowed to catch the script cancellation because the evaluation stack
* for the interp is completely unwound.
*/
if (resultObjPtr != NULL) {
result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length);
cancelInfo->result = (char *)Tcl_Realloc(cancelInfo->result, cancelInfo->length);
memcpy(cancelInfo->result, result, cancelInfo->length);
TclDecrRefCount(resultObjPtr); /* Discard their result object. */
} else {
cancelInfo->result = NULL;
cancelInfo->length = 0;
}
cancelInfo->clientData = clientData;
|
| ︙ | ︙ | |||
4377 4378 4379 4380 4381 4382 4383 |
* data[1] stores a marker for use by tailcalls; it will be set to 1 by
* command redirectors (imports, alias, ensembles) so that tailcall skips
* this callback (that marks the end of the target command) and goes back
* to the end of the source command.
*/
if (iPtr->deferredCallbacks) {
| | | | 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 |
* data[1] stores a marker for use by tailcalls; it will be set to 1 by
* command redirectors (imports, alias, ensembles) so that tailcall skips
* this callback (that marks the end of the target command) and goes back
* to the end of the source command.
*/
if (iPtr->deferredCallbacks) {
iPtr->deferredCallbacks = NULL;
} else {
TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
}
iPtr->numLevels++;
TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags),
INT2PTR(objc), objv);
return TCL_OK;
}
static int
EvalObjvCore(
void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0];
int flags = PTR2INT(data[1]);
Tcl_Size objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
Namespace *lookupNsPtr = NULL;
int enterTracesDone = 0;
/*
* Push records for task to be done on return, in INVERSE order. First, if
|
| ︙ | ︙ | |||
4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 |
}
if (objc == 0) {
return TCL_OK;
}
if (TclLimitExceeded(iPtr->limit)) {
return TCL_ERROR;
}
/*
* Configure evaluation context to match the requested flags.
*/
| > > > > | 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 |
}
if (objc == 0) {
return TCL_OK;
}
if (TclLimitExceeded(iPtr->limit)) {
/* generate error message if not yet already logged at this stage */
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
Tcl_LimitCheck(interp);
}
return TCL_ERROR;
}
/*
* Configure evaluation context to match the requested flags.
*/
|
| ︙ | ︙ | |||
4465 4466 4467 4468 4469 4470 4471 |
* Lookup the Command to dispatch.
*/
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
/*
| | | | | | | | 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 |
* Lookup the Command to dispatch.
*/
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
/*
* Caller gave it to us.
*/
if (!(preCmdPtr->flags & CMD_DEAD)) {
/*
* So long as it exists, use it.
*/
cmdPtr = preCmdPtr;
} else if (flags & TCL_EVAL_NORESOLVE) {
/*
* When it's been deleted, and we're told not to attempt resolving
* it ourselves, all we can do is raise an error.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to invoke a deleted command"));
Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", (char *)NULL);
return TCL_ERROR;
}
}
if (cmdPtr == NULL) {
cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
if (!cmdPtr) {
return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
}
}
if (enterTracesDone || iPtr->tracePtr
|| (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
Tcl_Obj *commandPtr = TclGetSourceFromFrame(
flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
objc, objv);
Tcl_IncrRefCount(commandPtr);
if (!enterTracesDone) {
int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
objc, objv);
|
| ︙ | ︙ | |||
4539 4540 4541 4542 4543 4544 4545 | * Schedule leave traces. Raise the refCount on the resolved cmdPtr, * so that when it passes to the leave traces we know it's still * valid. */ cmdPtr->refCount++; TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), | | | 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 |
* Schedule leave traces. Raise the refCount on the resolved cmdPtr,
* so that when it passes to the leave traces we know it's still
* valid.
*/
cmdPtr->refCount++;
TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
commandPtr, cmdPtr, objv);
}
TclNRAddCallback(interp, Dispatch,
cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc,
cmdPtr->objClientData, INT2PTR(objc), objv);
return TCL_OK;
}
|
| ︙ | ︙ | |||
4602 4603 4604 4605 4606 4607 4608 |
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
while (TOP_CB(interp) != rootPtr) {
| | | | | | | 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 |
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
while (TOP_CB(interp) != rootPtr) {
NRE_callback *callbackPtr = TOP_CB(interp);
Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
}
return result;
}
static int
NRCommand(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
iPtr->numLevels--;
/*
* If there is a tailcall, schedule it next
*/
if (data[1] && (data[1] != INT2PTR(1))) {
listPtr = (Tcl_Obj *)data[1];
data[1] = NULL;
TclNRAddCallback(interp, TclNRTailcallEval, listPtr, NULL, NULL, NULL);
}
|
| ︙ | ︙ | |||
4669 4670 4671 4672 4673 4674 4675 |
*
*----------------------------------------------------------------------
*/
static void
TEOV_PushExceptionHandlers(
Tcl_Interp *interp,
| | | 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 |
*
*----------------------------------------------------------------------
*/
static void
TEOV_PushExceptionHandlers(
Tcl_Interp *interp,
Tcl_Size objc,
Tcl_Obj *const objv[],
int flags)
{
Interp *iPtr = (Interp *) interp;
/*
* If any error processing is necessary, push the appropriate records.
|
| ︙ | ︙ | |||
4765 4766 4767 4768 4769 4770 4771 |
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
Tcl_Size cmdLen;
| | | | | | | | | | | 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 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 |
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
Tcl_Size cmdLen;
Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj **objv = (Tcl_Obj **)data[1];
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
/*
* If there was an error, a command string will be needed for the
* error log: get it out of the itemPtr. The details depend on the
* type.
*/
listPtr = Tcl_NewListObj(objc, objv);
cmdString = TclGetStringFromObj(listPtr, &cmdLen);
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(listPtr);
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
return result;
}
static int
TEOV_NotFound(
Tcl_Interp *interp,
Tcl_Size objc,
Tcl_Obj *const objv[],
Namespace *lookupNsPtr)
{
Command * cmdPtr;
Interp *iPtr = (Interp *) interp;
Tcl_Size i, newObjc, handlerObjc;
Tcl_Obj **newObjv, **handlerObjv;
CallFrame *varFramePtr = iPtr->varFramePtr;
Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered
* unknown command handler for the current
* namespace (TIP 181). */
Namespace *savedNsPtr = NULL;
currNsPtr = varFramePtr->nsPtr;
if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) {
currNsPtr = iPtr->globalNsPtr;
if (currNsPtr == NULL) {
Tcl_Panic("TEOV_NotFound: NULL global namespace pointer");
}
}
/*
* Check to see if the resolution namespace has lost its unknown handler.
* If so, reset it to "::unknown".
*/
if (currNsPtr->unknownHandlerPtr == NULL) {
TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
}
/*
* Get the list of words for the unknown handler and allocate enough space
* to hold both the handler prefix and all words of the command invocation
* itself.
*/
TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
/*
* Copy command prefix from unknown handler and add on the real command's
* full argument list. Note that we only use memcpy() once because we have
* to increment the reference count of all the handler arguments anyway.
*/
for (i = 0; i < handlerObjc; ++i) {
newObjv[i] = handlerObjv[i];
Tcl_IncrRefCount(newObjv[i]);
}
memcpy(newObjv + handlerObjc, objv, sizeof(Tcl_Obj *) * objc);
/*
* Look up and invoke the handler (by recursive call to this function). If
* there is no handler at all, instead of doing the recursive call we just
* generate a generic error message; it would be an infinite-recursion
* nightmare otherwise.
*
* In this case we worry a bit less about recursion for now, and call the
* "blocking" interface.
*/
cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
if (cmdPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[0]), (char *)NULL);
/*
* Release any resources we locked and allocated during the handler
* call.
*/
for (i = 0; i < handlerObjc; ++i) {
|
| ︙ | ︙ | |||
4888 4889 4890 4891 4892 4893 4894 |
static int
TEOV_NotFoundCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 |
static int
TEOV_NotFoundCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj **objv = (Tcl_Obj **)data[1];
Namespace *savedNsPtr = (Namespace *)data[2];
Tcl_Size i;
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
/*
* Release any resources we locked and allocated during the handler call.
|
| ︙ | ︙ | |||
4915 4916 4917 4918 4919 4920 4921 |
}
static int
TEOV_RunEnterTraces(
Tcl_Interp *interp,
Command **cmdPtrPtr,
Tcl_Obj *commandPtr,
| | | | 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 |
}
static int
TEOV_RunEnterTraces(
Tcl_Interp *interp,
Command **cmdPtrPtr,
Tcl_Obj *commandPtr,
Tcl_Size objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int traceCode = TCL_OK;
const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
* Execute any command or execution traces. Note that we bump up the
* command's reference count for the duration of the calling of the
* traces so that the structure doesn't go away underneath our feet.
*/
|
| ︙ | ︙ | |||
4969 4970 4971 4972 4973 4974 4975 |
TEOV_RunLeaveTraces(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
| | | | 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 |
TEOV_RunLeaveTraces(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Tcl_Size length;
const char *command = TclGetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_DYING)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
|
| ︙ | ︙ | |||
5056 5057 5058 5059 5060 5061 5062 |
int
Tcl_EvalTokensStandard(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
| | | 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 |
int
Tcl_EvalTokensStandard(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
Tcl_Size count) /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
NULL, NULL);
}
/*
|
| ︙ | ︙ | |||
5111 5112 5113 5114 5115 5116 5117 |
Tcl_Size numBytes, /* Number of bytes in script. If -1, the
* script consists of all bytes up to the
* first NUL character. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
Tcl_Size line, /* The line the script starts on. */
| | | 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 |
Tcl_Size numBytes, /* Number of bytes in script. If -1, the
* script consists of all bytes up to the
* first NUL character. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
Tcl_Size line, /* The line the script starts on. */
Tcl_Size *clNextOuter, /* Information about an outer context for */
const char *outerScript) /* continuation line data. This is set only in
* TclSubstTokens(), to properly handle
* [...]-nested commands. The 'outerScript'
* refers to the most-outer script containing
* the embedded command, which is referred to
* by 'script'. The 'clNextOuter' refers to
* the current entry in the table of
|
| ︙ | ︙ | |||
5149 5150 5151 5152 5153 5154 5155 |
Tcl_Size i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
* properly if an error occurs. */
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
CmdFrame *eeFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
| | < | | 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 |
Tcl_Size i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
* properly if an error occurs. */
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
CmdFrame *eeFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
Tcl_Obj **stackObjArray = (Tcl_Obj **)TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
Tcl_Size *linesStack = (Tcl_Size *)TclStackAlloc(interp, minObjs * sizeof(Tcl_Size));
/* TIP #280 Structures for tracking of command
* locations. */
Tcl_Size *clNext = NULL; /* Pointer for the tracking of invisible
* continuation lines. Initialized only if the
* caller gave us a table of locations to
* track, via scriptCLLocPtr. It always refers
* to the table entry holding the location of
* the next invisible continuation line to
* look for, while parsing the script. */
|
| ︙ | ︙ | |||
5288 5289 5290 5291 5292 5293 5294 |
Tcl_Size numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
| | | > | > | | 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 |
Tcl_Size numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
expand = (int *)Tcl_Alloc(numWords * sizeof(int));
objvSpace = (Tcl_Obj **)
Tcl_Alloc(numWords * sizeof(Tcl_Obj *));
lineSpace = (Tcl_Size *)
Tcl_Alloc(numWords * sizeof(Tcl_Size));
}
expandRequested = 0;
objv = objvSpace;
lines = lineSpace;
iPtr->cmdFramePtr = eeFramePtr->nextPtr;
for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr;
objectsUsed < numWords;
objectsUsed++, tokenPtr += tokenPtr->numComponents + 1) {
Tcl_Size additionalObjsCount;
/*
* TIP #280. Track lines to current word. Save the information
* on a per-word basis, signaling dynamic words as needed.
* Make the information available to the recursively called
* evaluator as well, including the type of context (source
|
| ︙ | ︙ | |||
5322 5323 5324 5325 5326 5327 5328 |
lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL)
? wordLine : -1;
if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
| | | | | | 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 |
lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL)
? wordLine : -1;
if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
code = TclSubstTokens(interp, tokenPtr + 1,
tokenPtr->numComponents, NULL, wordLine,
wordCLNext, outerScript);
iPtr->evalFlags = 0;
if (code != TCL_OK) {
break;
}
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
Tcl_Size numElements;
code = TclListObjLength(interp, objv[objectsUsed],
&numElements);
if (code == TCL_ERROR) {
/*
* Attempt to expand a non-list.
*/
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (expanding word %" TCL_SIZE_MODIFIER "d)", objectsUsed));
Tcl_DecrRefCount(objv[objectsUsed]);
break;
}
expandRequested = 1;
expand[objectsUsed] = 1;
additionalObjsCount = (numElements ? numElements : 1);
} else {
expand[objectsUsed] = 0;
additionalObjsCount = 1;
}
/* Currently max command words in INT_MAX */
if (additionalObjsCount > INT_MAX ||
objectsNeeded > (INT_MAX - additionalObjsCount)) {
code = TclCommandWordLimitError(interp, -1);
Tcl_DecrRefCount(objv[objectsUsed]);
break;
}
objectsNeeded += additionalObjsCount;
if (wordCLNext) {
|
| ︙ | ︙ | |||
5387 5388 5389 5390 5391 5392 5393 |
Tcl_Obj **copy = objvSpace;
Tcl_Size *lcopy = lineSpace;
Tcl_Size wordIdx = numWords;
Tcl_Size objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
| < | | | | 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 |
Tcl_Obj **copy = objvSpace;
Tcl_Size *lcopy = lineSpace;
Tcl_Size wordIdx = numWords;
Tcl_Size objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace = (Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *));
lines = lineSpace = (Tcl_Size *)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Size));
}
objectsUsed = 0;
while (wordIdx--) {
if (expand[wordIdx]) {
Tcl_Size numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
TclListObjGetElements(NULL, temp, &numElements,
&elements);
objectsUsed += numElements;
while (numElements--) {
lines[objIdx] = -1;
objv[objIdx--] = elements[numElements];
Tcl_IncrRefCount(elements[numElements]);
}
Tcl_DecrRefCount(temp);
} else {
lines[objIdx] = lcopy[wordIdx];
objv[objIdx--] = copy[wordIdx];
objectsUsed++;
}
}
objv += objIdx + 1;
if (copy != stackObjArray) {
Tcl_Free(copy);
}
if (lcopy != linesStack) {
Tcl_Free(lcopy);
}
|
| ︙ | ︙ | |||
5683 5684 5685 5686 5687 5688 5689 |
*----------------------------------------------------------------------
*/
void
TclArgumentEnter(
Tcl_Interp *interp,
Tcl_Obj **objv,
| | | > | 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 |
*----------------------------------------------------------------------
*/
void
TclArgumentEnter(
Tcl_Interp *interp,
Tcl_Obj **objv,
Tcl_Size objc,
CmdFrame *cfPtr)
{
Interp *iPtr = (Interp *) interp;
int isNew;
Tcl_Size i;
Tcl_HashEntry *hPtr;
CFWord *cfwPtr;
for (i = 1; i < objc; i++) {
/*
* Ignore argument words without line information (= dynamic). If they
* are variables they may have location information associated with
|
| ︙ | ︙ | |||
5751 5752 5753 5754 5755 5756 5757 |
*----------------------------------------------------------------------
*/
void
TclArgumentRelease(
Tcl_Interp *interp,
Tcl_Obj **objv,
| | | < | | 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 |
*----------------------------------------------------------------------
*/
void
TclArgumentRelease(
Tcl_Interp *interp,
Tcl_Obj **objv,
Tcl_Size objc)
{
Interp *iPtr = (Interp *) interp;
Tcl_Size i;
for (i = 1; i < objc; i++) {
CFWord *cfwPtr;
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]);
if (!hPtr) {
continue;
}
cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
if (cfwPtr->refCount-- > 1) {
|
| ︙ | ︙ | |||
5799 5800 5801 5802 5803 5804 5805 |
*----------------------------------------------------------------------
*/
void
TclArgumentBCEnter(
Tcl_Interp *interp,
Tcl_Obj *objv[],
| | | < | | 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 |
*----------------------------------------------------------------------
*/
void
TclArgumentBCEnter(
Tcl_Interp *interp,
Tcl_Obj *objv[],
Tcl_Size objc,
void *codePtr,
CmdFrame *cfPtr,
Tcl_Size cmd,
Tcl_Size pc)
{
ExtCmdLoc *eclPtr;
Tcl_Size word;
ECL *ePtr;
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
ePtr = &eclPtr->loc[cmd];
|
| ︙ | ︙ | |||
5833 5834 5835 5836 5837 5838 5839 |
* evaluation are not supposed to get compiled, because a command
* such as [info level] in the script can expose some of the dispatch
* shenanigans. This means that we don't have to tend to the
* housekeeping, and can escape now.
*/
if (ePtr->nline != objc) {
| | | | 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 |
* evaluation are not supposed to get compiled, because a command
* such as [info level] in the script can expose some of the dispatch
* shenanigans. This means that we don't have to tend to the
* housekeeping, and can escape now.
*/
if (ePtr->nline != objc) {
return;
}
/*
* Having disposed of the ensemble cases, we can state...
* A few truths ...
* (1) ePtr->nline == objc
* (2) (ePtr->line[word] < 0) => !literal, for all words
* (3) (word == 0) => !literal
*
* Item (2) is why we can use objv to get the literals, and do not
* have to save them at compile time.
*/
for (word = 1; word < objc; word++) {
if (ePtr->line[word] >= 0) {
int isNew;
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr,
objv[word], &isNew);
CFWordBC *cfwPtr = (CFWordBC *)Tcl_Alloc(sizeof(CFWordBC));
cfwPtr->framePtr = cfPtr;
cfwPtr->obj = objv[word];
cfwPtr->pc = pc;
cfwPtr->word = word;
cfwPtr->nextPtr = lastPtr;
|
| ︙ | ︙ | |||
6041 6042 6043 6044 6045 6046 6047 |
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
| | | | | 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 |
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
{
return TclEvalObjEx(interp, objPtr, flags, NULL, 0);
}
int
TclEvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
const CmdFrame *invoker, /* Frame of the command doing the eval. */
int word) /* Index of the word which is in objPtr. */
{
int result = TCL_OK;
NRE_callback *rootPtr = TOP_CB(interp);
result = TclNREvalObjEx(interp, objPtr, flags, invoker, word);
return TclNRRunCallbacks(interp, result, rootPtr);
}
int
TclNREvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
const CmdFrame *invoker, /* Frame of the command doing the eval. */
int word) /* Index of the word which is in objPtr. */
{
|
| ︙ | ︙ | |||
6158 6159 6160 6161 6162 6163 6164 | iPtr->cmdFramePtr = eoFramePtr; flags |= TCL_EVAL_SOURCE_IN_FRAME; } TclMarkTailcall(interp); | | | | | | | | 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 |
iPtr->cmdFramePtr = eoFramePtr;
flags |= TCL_EVAL_SOURCE_IN_FRAME;
}
TclMarkTailcall(interp);
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
if (!(flags & TCL_EVAL_DIRECT)) {
/*
* Let the compiler/engine subsystem do the evaluation.
*
* TIP #280 The invoker provides us with the context for the script.
* We transfer this to the byte code compiler.
*/
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
ByteCode *codePtr;
CallFrame *savedVarFramePtr = NULL; /* Saves old copy of
* iPtr->varFramePtr in case
* TCL_EVAL_GLOBAL was set. */
if (TclInterpReady(interp) != TCL_OK) {
return TCL_ERROR;
}
if (flags & TCL_EVAL_GLOBAL) {
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
}
Tcl_IncrRefCount(objPtr);
codePtr = TclCompileObj(interp, objPtr, invoker, word);
TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr,
objPtr, INT2PTR(allowExceptions), NULL);
return TclNRExecuteByteCode(interp, codePtr);
}
{
/*
* We're not supposed to use the compiler or byte-code
* interpreter. Let Tcl_EvalEx evaluate the command directly (and
* probably more slowly).
|
| ︙ | ︙ | |||
6229 6230 6231 6232 6233 6234 6235 | assert(invoker == NULL); iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); Tcl_IncrRefCount(objPtr); | | | 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 |
assert(invoker == NULL);
iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr);
Tcl_IncrRefCount(objPtr);
script = TclGetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
iPtr->scriptCLLocPtr = saveCLLocPtr;
return result;
}
|
| ︙ | ︙ | |||
6260 6261 6262 6263 6264 6265 6266 |
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
const char *script;
Tcl_Size numSrcBytes;
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
| | | 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 |
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
const char *script;
Tcl_Size numSrcBytes;
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
/*
* We are returning to level 0, so should call TclResetCancellation.
* Let us just unset the flags inline.
*/
|
| ︙ | ︙ | |||
6341 6342 6343 6344 6345 6346 6347 |
int returnCode) /* The unexpected result code. */
{
char buf[TCL_INTEGER_SPACE];
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | | 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 |
int returnCode) /* The unexpected result code. */
{
char buf[TCL_INTEGER_SPACE];
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invoked \"break\" outside of a loop", TCL_INDEX_NONE));
} else if (returnCode == TCL_CONTINUE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invoked \"continue\" outside of a loop", TCL_INDEX_NONE));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"command returned bad code: %d", returnCode));
}
snprintf(buf, sizeof(buf), "%d", returnCode);
Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, (char *)NULL);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
*
|
| ︙ | ︙ | |||
6390 6391 6392 6393 6394 6395 6396 |
if (*exprstring == '\0') {
/*
* Legacy compatibility - return 0 for the zero-length string.
*/
*ptr = 0;
} else {
| | | 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 |
if (*exprstring == '\0') {
/*
* Legacy compatibility - return 0 for the zero-length string.
*/
*ptr = 0;
} else {
exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprLongObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
}
return result;
}
|
| ︙ | ︙ | |||
6415 6416 6417 6418 6419 6420 6421 |
if (*exprstring == '\0') {
/*
* Legacy compatibility - return 0 for the zero-length string.
*/
*ptr = 0.0;
} else {
| | | 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 |
if (*exprstring == '\0') {
/*
* Legacy compatibility - return 0 for the zero-length string.
*/
*ptr = 0.0;
} else {
exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
/* Discard the expression object. */
}
return result;
}
|
| ︙ | ︙ | |||
6440 6441 6442 6443 6444 6445 6446 |
* An empty string. Just set the result boolean to 0 (false).
*/
*ptr = 0;
return TCL_OK;
} else {
int result;
| | | 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 |
* An empty string. Just set the result boolean to 0 (false).
*/
*ptr = 0;
return TCL_OK;
} else {
int result;
Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
return result;
}
}
|
| ︙ | ︙ | |||
6474 6475 6476 6477 6478 6479 6480 |
*--------------------------------------------------------------
*/
int
Tcl_ExprLongObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
| | | | 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 |
*--------------------------------------------------------------
*/
int
Tcl_ExprLongObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Expression to evaluate. */
long *ptr) /* Where to store long result. */
{
Tcl_Obj *resultPtr;
int result, type;
double d;
void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK) {
return TCL_ERROR;
}
switch (type) {
case TCL_NUMBER_DOUBLE: {
mp_int big;
|
| ︙ | ︙ | |||
6521 6522 6523 6524 6525 6526 6527 |
return result;
}
int
Tcl_ExprDoubleObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
| | | 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 |
return result;
}
int
Tcl_ExprDoubleObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Expression to evaluate. */
double *ptr) /* Where to store double result. */
{
Tcl_Obj *resultPtr;
int result, type;
void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
| ︙ | ︙ | |||
6557 6558 6559 6560 6561 6562 6563 |
return result;
}
int
Tcl_ExprBooleanObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
| | | 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 |
return result;
}
int
Tcl_ExprBooleanObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Expression to evaluate. */
int *ptr) /* Where to store 0/1 result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
|
| ︙ | ︙ | |||
6597 6598 6599 6600 6601 6602 6603 |
*----------------------------------------------------------------------
*/
int
TclObjInvokeNamespace(
Tcl_Interp *interp, /* Interpreter in which command is to be
* invoked. */
| | | 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 |
*----------------------------------------------------------------------
*/
int
TclObjInvokeNamespace(
Tcl_Interp *interp, /* Interpreter in which command is to be
* invoked. */
Tcl_Size objc, /* Count of arguments. */
Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the
* name of the command to invoke. */
Tcl_Namespace *nsPtr, /* The namespace to use. */
int flags) /* Combination of flags controlling the call:
* TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,
* or TCL_INVOKE_NO_TRACEBACK. */
{
|
| ︙ | ︙ | |||
6641 6642 6643 6644 6645 6646 6647 |
*----------------------------------------------------------------------
*/
int
TclObjInvoke(
Tcl_Interp *interp, /* Interpreter in which command is to be
* invoked. */
| | | | 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 |
*----------------------------------------------------------------------
*/
int
TclObjInvoke(
Tcl_Interp *interp, /* Interpreter in which command is to be
* invoked. */
Tcl_Size objc, /* Count of arguments. */
Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the
* name of the command to invoke. */
int flags) /* Combination of flags controlling the call:
* TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,
* or TCL_INVOKE_NO_TRACEBACK. */
{
if (interp == NULL) {
return TCL_ERROR;
}
if ((objc < 1) || (objv == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal argument vector", TCL_INDEX_NONE));
return TCL_ERROR;
}
if ((flags & TCL_INVOKE_HIDDEN) == 0) {
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
|
| ︙ | ︙ | |||
6682 6683 6684 6685 6686 6687 6688 |
cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 |
cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
(char *)NULL);
return TCL_ERROR;
}
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Avoid the exception-handling brain damage when numLevels == 0
*/
|
| ︙ | ︙ | |||
6752 6753 6754 6755 6756 6757 6758 |
if (expr[0] == '\0') {
/*
* An empty string. Just set the interpreter's result to 0.
*/
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
| | | 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 |
if (expr[0] == '\0') {
/*
* An empty string. Just set the interpreter's result to 0.
*/
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprObj);
code = Tcl_ExprObj(interp, exprObj, &resultPtr);
Tcl_DecrRefCount(exprObj);
if (code == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
|
| ︙ | ︙ | |||
6791 6792 6793 6794 6795 6796 6797 |
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
Tcl_Size length;
| | | | 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 |
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
Tcl_Size length;
const char *message = TclGetStringFromObj(objPtr, &length);
Interp *iPtr = (Interp *) interp;
Tcl_IncrRefCount(objPtr);
/*
* If we are just starting to log an error, errorInfo is initialized from
* the error message in the interpreter's result.
*/
iPtr->flags |= ERR_LEGACY_COPY;
if (iPtr->errorInfo == NULL) {
iPtr->errorInfo = iPtr->objResultPtr;
Tcl_IncrRefCount(iPtr->errorInfo);
if (!iPtr->errorCode) {
Tcl_SetErrorCode(interp, "NONE", (char *)NULL);
}
}
/*
* Now append "message" to the end of errorInfo.
*/
|
| ︙ | ︙ | |||
6866 6867 6868 6869 6870 6871 6872 |
Tcl_DStringInit(&buf);
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
| | | | 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 |
Tcl_DStringInit(&buf);
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
Tcl_DStringAppend(&buf, string, TCL_INDEX_NONE);
}
result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), TCL_INDEX_NONE, 0);
Tcl_DStringFree(&buf);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
7172 7173 7174 7175 7176 7177 7178 |
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
negarg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 |
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
negarg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"square root of negative argument", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", (char *)NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
|
| ︙ | ︙ | |||
7232 7233 7234 7235 7236 7237 7238 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d)));
}
return TCL_OK;
}
static int
ExprUnaryFunc(
| | | | 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d)));
}
return TCL_OK;
}
static int
ExprUnaryFunc(
void *clientData, /* Contains the address of a function that
* takes one double argument and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
int code;
double d;
BuiltinUnaryFunc *func = (BuiltinUnaryFunc *) clientData;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
|
| ︙ | ︙ | |||
7296 7297 7298 7299 7300 7301 7302 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprBinaryFunc(
| | | | 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprBinaryFunc(
void *clientData, /* Contains the address of a function that
* takes two double arguments and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
int code;
double d1, d2;
BuiltinBinaryFunc *func = (BuiltinBinaryFunc *)clientData;
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
|
| ︙ | ︙ | |||
7375 7376 7377 7378 7379 7380 7381 |
Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
if (l > 0) {
goto unChanged;
} else if (l == 0) {
if (TclHasStringRep(objv[1])) {
Tcl_Size numBytes;
| | | > | 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 |
Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
if (l > 0) {
goto unChanged;
} else if (l == 0) {
if (TclHasStringRep(objv[1])) {
Tcl_Size numBytes;
const char *bytes = TclGetStringFromObj(objv[1], &numBytes);
while (numBytes) {
if (*bytes == '-') {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
bytes++;
numBytes--;
}
}
goto unChanged;
} else if (l == WIDE_MIN) {
if (sizeof(Tcl_WideInt) > sizeof(int64_t)) {
Tcl_WideUInt ul = -(Tcl_WideUInt)WIDE_MIN;
if (mp_init(&big) != MP_OKAY || mp_unpack(&big, 1, 1,
|
| ︙ | ︙ | |||
7590 7591 7592 7593 7594 7595 7596 |
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv, /* Actual parameter vector. */
int op) /* Comparison direction */
{
Tcl_Obj *res;
double d;
| | > | | | | | | | | | | | | | | 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 |
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv, /* Actual parameter vector. */
int op) /* Comparison direction */
{
Tcl_Obj *res;
double d;
int type;
int i;
void *ptr;
if (objc < 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
res = objv[1];
for (i = 1; i < objc; i++) {
if (Tcl_GetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_NAN) {
/*
* Get the error message for NaN.
*/
Tcl_GetDoubleFromObj(interp, objv[i], &d);
return TCL_ERROR;
}
if (TclCompareTwoNumbers(objv[i], res) == op) {
res = objv[i];
}
}
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
|
| ︙ | ︙ | |||
7668 7669 7670 7671 7672 7673 7674 | iPtr->flags |= RAND_SEED_INITIALIZED; /* * To ensure different seeds in different threads (bug #416643), * take into consideration the thread this interp is running in. */ | | | 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 |
iPtr->flags |= RAND_SEED_INITIALIZED;
/*
* To ensure different seeds in different threads (bug #416643),
* take into consideration the thread this interp is running in.
*/
iPtr->randSeed = TclpGetClicks() + PTR2UINT(Tcl_GetCurrentThread()) * 4093U;
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= 0x7FFFFFFFL;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFFL)) {
|
| ︙ | ︙ | |||
7865 7866 7867 7868 7869 7870 7871 | *---------------------------------------------------------------------- * * Double Classification Functions -- * * This page contains the functions that implement all of the built-in * math functions for classifying IEEE doubles. * | | | | 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 | *---------------------------------------------------------------------- * * Double Classification Functions -- * * This page contains the functions that implement all of the built-in * math functions for classifying IEEE doubles. * * These have to be a little bit careful while Tcl_GetDoubleFromObj() * rejects NaN values, which these functions *explicitly* accept. * * Results: * Each function returns TCL_OK if it succeeds and pushes an Tcl object * holding the result. If it fails it returns TCL_ERROR and leaves an * error message in the interpreter's result. * * Side effects: |
| ︙ | ︙ | |||
7900 7901 7902 7903 7904 7905 7906 |
return fpclassify(d);
#else /* TCL_FPCLASSIFY_MODE != 0 */
/*
* If we don't have fpclassify(), we also don't have the values it returns.
* Hence we define those here.
*/
#ifndef FP_NAN
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < | < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | < < < | < < < < < | | > | < < < < < | | | | | | | | | | | | | | | | | | | | | 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 |
return fpclassify(d);
#else /* TCL_FPCLASSIFY_MODE != 0 */
/*
* If we don't have fpclassify(), we also don't have the values it returns.
* Hence we define those here.
*/
#ifndef FP_NAN
# define FP_NAN 1 /* Value is NaN */
# define FP_INFINITE 2 /* Value is an infinity */
# define FP_ZERO 3 /* Value is a zero */
# define FP_NORMAL 4 /* Value is a normal float */
# define FP_SUBNORMAL 5 /* Value has lost accuracy */
#endif /* !FP_NAN */
#if TCL_FPCLASSIFY_MODE == 3
return __builtin_fpclassify(
FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d);
#elif TCL_FPCLASSIFY_MODE == 2
/*
* We assume this hack is only needed on little-endian systems.
* Specifically, x86 running Windows. It's fairly easy to enable for
* others if they need it (because their libc/libm is broken) but we'll
* jump that hurdle when requred. We can solve the word ordering then.
*/
union {
double d; /* Interpret as double */
struct {
unsigned int low; /* Lower 32 bits */
unsigned int high; /* Upper 32 bits */
} w; /* Interpret as unsigned integer words */
} doubleMeaning; /* So we can look at the representation of a
* double directly. Platform (i.e., processor)
* specific; this is for x86 (and most other
* little-endian processors, but those are
* untested). */
unsigned int exponent, mantissaLow, mantissaHigh;
/* The pieces extracted from the double. */
int zeroMantissa; /* Was the mantissa zero? That's special. */
/*
* Shifts and masks to use with the doubleMeaning variable above.
*/
#define EXPONENT_MASK 0x7FF /* 11 bits (after shifting) */
#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */
#define MANTISSA_MASK 0xFFFFF /* 20 bits (plus 32 from other word) */
/*
* Extract the exponent (11 bits) and mantissa (52 bits). Note that we
* totally ignore the sign bit.
*/
doubleMeaning.d = d;
exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK;
mantissaLow = doubleMeaning.w.low;
mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK;
zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0);
/*
* Look for the special cases of exponent.
*/
switch (exponent) {
case 0:
/*
* When the exponent is all zeros, it's a ZERO or a SUBNORMAL.
*/
return zeroMantissa ? FP_ZERO : FP_SUBNORMAL;
case EXPONENT_MASK:
/*
* When the exponent is all ones, it's an INF or a NAN.
*/
return zeroMantissa ? FP_INFINITE : FP_NAN;
default:
/*
* Everything else is a NORMAL double precision float.
*/
return FP_NORMAL;
}
#elif TCL_FPCLASSIFY_MODE == 1
switch (_fpclass(d)) {
case _FPCLASS_NZ:
case _FPCLASS_PZ:
return FP_ZERO;
case _FPCLASS_NN:
case _FPCLASS_PN:
return FP_NORMAL;
case _FPCLASS_ND:
case _FPCLASS_PD:
return FP_SUBNORMAL;
case _FPCLASS_NINF:
case _FPCLASS_PINF:
return FP_INFINITE;
default:
Tcl_Panic("result of _fpclass() outside documented range!");
case _FPCLASS_QNAN:
case _FPCLASS_SNAN:
return FP_NAN;
}
#else /* TCL_FPCLASSIFY_MODE not in (0..3) */
#error "unknown or unexpected TCL_FPCLASSIFY_MODE"
#endif /* TCL_FPCLASSIFY_MODE */
#endif /* !fpclassify */
}
static inline int
DoubleObjClass(
Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Object with double to get its class. */
int *fpClsPtr) /* FP class retrieved for double in object. */
{
double d;
void *ptr;
int type;
if (Tcl_GetNumberFromObj(interp, objPtr, &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
switch (type) {
case TCL_NUMBER_NAN:
*fpClsPtr = FP_NAN;
return TCL_OK;
case TCL_NUMBER_DOUBLE:
d = *((const double *) ptr);
break;
case TCL_NUMBER_INT:
d = (double)*((const Tcl_WideInt *) ptr);
break;
default:
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
}
break;
}
*fpClsPtr = ClassifyDouble(d);
return TCL_OK;
}
static inline int
DoubleObjIsClass(
Tcl_Interp *interp,
int objc, /* Actual parameter count */
Tcl_Obj *const *objv, /* Actual parameter list */
int cmpCls, /* FP class to compare. */
int positive) /* 1 if compare positive, 0 - otherwise */
{
int dCls;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (DoubleObjClass(interp, objv[1], &dCls) != TCL_OK) {
return TCL_ERROR;
}
dCls = (
positive
? (dCls == cmpCls)
: (dCls != cmpCls && dCls != FP_NAN)
) ? 1 : 0;
Tcl_SetObjResult(interp, ((Interp *)interp)->execEnvPtr->constants[dCls]);
return TCL_OK;
}
static int
ExprIsFiniteFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
return DoubleObjIsClass(interp, objc, objv, FP_INFINITE, 0);
}
static int
ExprIsInfinityFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
return DoubleObjIsClass(interp, objc, objv, FP_INFINITE, 1);
}
static int
ExprIsNaNFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
return DoubleObjIsClass(interp, objc, objv, FP_NAN, 1);
}
static int
ExprIsNormalFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
return DoubleObjIsClass(interp, objc, objv, FP_NORMAL, 1);
}
static int
ExprIsSubnormalFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
return DoubleObjIsClass(interp, objc, objv, FP_SUBNORMAL, 1);
}
static int
ExprIsUnorderedFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
int dCls, dCls2;
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
return TCL_ERROR;
}
if (
DoubleObjClass(interp, objv[1], &dCls) != TCL_OK ||
DoubleObjClass(interp, objv[2], &dCls2) != TCL_OK
) {
return TCL_ERROR;
}
dCls = ((dCls == FP_NAN) || (dCls2 == FP_NAN)) ? 1 : 0;
Tcl_SetObjResult(interp, ((Interp *)interp)->execEnvPtr->constants[dCls]);
return TCL_OK;
}
static int
FloatClassifyObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
Tcl_Obj *objPtr;
void *ptr;
int type;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "floatValue");
return TCL_ERROR;
}
if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_NAN) {
goto gotNaN;
} else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
return TCL_ERROR;
}
switch (ClassifyDouble(d)) {
case FP_INFINITE:
TclNewLiteralStringObj(objPtr, "infinite");
break;
case FP_NAN:
gotNaN:
TclNewLiteralStringObj(objPtr, "nan");
break;
case FP_NORMAL:
TclNewLiteralStringObj(objPtr, "normal");
break;
case FP_SUBNORMAL:
TclNewLiteralStringObj(objPtr, "subnormal");
break;
case FP_ZERO:
TclNewLiteralStringObj(objPtr, "zero");
break;
default:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to classify number: %f", d));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
8273 8274 8275 8276 8277 8278 8279 |
int expected, /* Formal parameter count. */
int found, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
const char *name = TclGetString(objv[0]);
const char *tail = name + strlen(name);
| | | | | 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 |
int expected, /* Formal parameter count. */
int found, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
const char *name = TclGetString(objv[0]);
const char *tail = name + strlen(name);
while (tail > name + 1) {
tail--;
if (*tail == ':' && tail[-1] == ':') {
name = tail + 1;
break;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s arguments for math function \"%s\"",
(found < expected ? "not enough" : "too many"), name));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL);
}
#ifdef USE_DTRACE
/*
*----------------------------------------------------------------------
*
* DTraceObjCmd --
|
| ︙ | ︙ | |||
8464 8465 8466 8467 8468 8469 8470 |
NRE_callback *rootPtr = TOP_CB(interp);
TclNRAddCallback(interp, Dispatch, objProc, clientData,
INT2PTR(objc), objv);
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
| > | | | | 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 |
NRE_callback *rootPtr = TOP_CB(interp);
TclNRAddCallback(interp, Dispatch, objProc, clientData,
INT2PTR(objc), objv);
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
static int
wrapperNRObjProc(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CmdWrapperInfo *info = (CmdWrapperInfo *) clientData;
clientData = info->clientData;
Tcl_ObjCmdProc2 *proc = info->proc;
Tcl_Free(info);
if (objc < 0) {
objc = -1;
}
return proc(clientData, interp, (Tcl_Size) objc, objv);
}
int
Tcl_NRCallObjProc2(
Tcl_Interp *interp,
Tcl_ObjCmdProc2 *objProc,
void *clientData,
|
| ︙ | ︙ | |||
8531 8532 8533 8534 8535 8536 8537 | * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for details * on the calling sequence. * *---------------------------------------------------------------------- */ | | > | > | > | 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 |
* Tcl_ObjCmdProc proc will be called. When the command is deleted from
* the table, deleteProc will be called. See the manual entry for details
* on the calling sequence.
*
*----------------------------------------------------------------------
*/
static int
cmdWrapperNreProc(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CmdWrapperInfo *info = (CmdWrapperInfo *) clientData;
if (objc < 0) {
objc = -1;
}
return info->nreProc(info->clientData, interp, objc, objv);
}
Tcl_Command
Tcl_NRCreateCommand2(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
* name, provides direct access for direct
* calls. */
Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with
* name, provides NR implementation */
void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo));
info->proc = proc;
info->clientData = clientData;
info->nreProc = nreProc;
info->deleteProc = deleteProc;
info->deleteData = clientData;
return Tcl_NRCreateCommand(interp, cmdName,
(proc ? cmdWrapperProc : NULL),
|
| ︙ | ︙ | |||
8588 8589 8590 8591 8592 8593 8594 |
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name, provides direct access for direct
* calls. */
Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with
* name, provides NR implementation */
| | | | | | 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 |
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name, provides direct access for direct
* calls. */
Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with
* name, provides NR implementation */
void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
Command *cmdPtr = (Command *)
Tcl_CreateObjCommand(interp, cmdName, proc, clientData,
deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
}
Tcl_Command
TclNRCreateCommandInNs(
Tcl_Interp *interp,
const char *cmdName,
Tcl_Namespace *nsPtr,
Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc,
void *clientData,
Tcl_CmdDeleteProc *deleteProc)
{
Command *cmdPtr = (Command *)
TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData,
deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
}
/****************************************************************************
* Stuff for the public api
|
| ︙ | ︙ | |||
8637 8638 8639 8640 8641 8642 8643 |
return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
}
int
Tcl_NREvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
| | | 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 |
return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
}
int
Tcl_NREvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
Tcl_Size objc, /* Number of words in command. */
Tcl_Obj *const objv[], /* An array of pointers to objects that are
* the words that make up the command. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
* TCL_EVAL_NOERR are currently supported. */
{
|
| ︙ | ︙ | |||
8678 8679 8680 8681 8682 8683 8684 | * 3. when the NRCommand callback runs, it schedules the tailcall callback * to run immediately after it returns * * One delicate point is to properly define the NRCommand where the tailcall * will execute. There are functions whose purpose is to help define the * precise spot: * TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution | | | | | | | | | | 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 |
* 3. when the NRCommand callback runs, it schedules the tailcall callback
* to run immediately after it returns
*
* One delicate point is to properly define the NRCommand where the tailcall
* will execute. There are functions whose purpose is to help define the
* precise spot:
* TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution
* should continue right here
* TclSkipTailcall: if the NEXT command to be pushed tailcalls, execution
* should continue after the CURRENT command is fully returned ("skip
* the next command: we are redirecting to it, tailcalls should run
* after WE return")
* TclPushTailcallPoint: the search for a tailcalling spot cannot traverse
* this point. This is special for OO, as some of the oo constructs
* that behave like commands may not push an NRCommand callback.
*/
void
TclMarkTailcall(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
if (iPtr->deferredCallbacks == NULL) {
TclNRAddCallback(interp, NRCommand, NULL, NULL,
NULL, NULL);
iPtr->deferredCallbacks = TOP_CB(interp);
}
}
void
TclSkipTailcall(
Tcl_Interp *interp)
{
|
| ︙ | ︙ | |||
8744 8745 8746 8747 8748 8749 8750 |
* being tailcalled. Note that we skip NRCommands marked by a 1 in data[1]
* (used by command redirectors).
*/
NRE_callback *runPtr;
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
| | | | | | 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 |
* being tailcalled. Note that we skip NRCommands marked by a 1 in data[1]
* (used by command redirectors).
*/
NRE_callback *runPtr;
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
}
}
if (!runPtr) {
Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
}
runPtr->data[1] = listPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
8785 8786 8787 8788 8789 8790 8791 |
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
return TCL_ERROR;
}
if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
| | | | | | | | | | | | < | | | | 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 |
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
return TCL_ERROR;
}
if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tailcall can only be called from a proc, lambda or method", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL);
return TCL_ERROR;
}
/*
* Invocation without args just clears a scheduled tailcall; invocation
* with an argument replaces any previously scheduled tailcall.
*/
if (iPtr->varFramePtr->tailcallPtr) {
Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
iPtr->varFramePtr->tailcallPtr = NULL;
}
/*
* Create the callback to actually evaluate the tailcalled
* command, then set it in the varFrame so that PopCallFrame can use it
* at the proper time.
*/
if (objc > 1) {
Tcl_Obj *listPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
/*
* The tailcall data is in a Tcl list: the first element is the
* namespace, the rest the command to be tailcalled.
*/
listPtr = Tcl_NewListObj(objc, objv);
TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj(nsPtr));
iPtr->varFramePtr->tailcallPtr = listPtr;
}
return TCL_RETURN;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
8847 8848 8849 8850 8851 8852 8853 |
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
Tcl_Size objc;
Tcl_Obj **objv;
| | | | | | | | | 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 |
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
Tcl_Size objc;
Tcl_Obj **objv;
TclListObjGetElements(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
}
if (result != TCL_OK) {
/*
* Tailcall execution was preempted, eg by an intervening catch or by
* a now-gone namespace: cleanup and return.
*/
Tcl_DecrRefCount(listPtr);
return result;
}
/*
* Perform the tailcall
*/
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc - 1, objv + 1, 0, NULL);
}
int
TclNRReleaseValues(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
|
| ︙ | ︙ | |||
8948 8949 8950 8951 8952 8953 8954 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
return TCL_ERROR;
}
if (!corPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | < > | | | | | | | < | | 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
return TCL_ERROR;
}
if (!corPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yield can only be called in a coroutine", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (char *)NULL);
return TCL_ERROR;
}
if (objc == 2) {
Tcl_SetObjResult(interp, objv[1]);
}
NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
Tcl_Obj *listPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
}
if (!corPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yieldto can only be called in a coroutine", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (char *)NULL);
return TCL_ERROR;
}
if (((Namespace *) nsPtr)->flags & NS_DYING) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yieldto called in deleted namespace", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
(char *)NULL);
return TCL_ERROR;
}
/*
* Add the tailcall in the caller env, then just yield.
*
* This is essentially code from TclNRTailcallObjCmd
*/
listPtr = Tcl_NewListObj(objc, objv);
TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj(nsPtr));
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
iPtr->execEnvPtr = corPtr->callerEEPtr;
/* Not calling Tcl_IncrRefCount(listPtr) here because listPtr is private */
|
| ︙ | ︙ | |||
9156 9157 9158 9159 9160 9161 9162 | } /* *---------------------------------------------------------------------- * * TclNRCoroutineActivateCallback -- * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 |
}
/*
*----------------------------------------------------------------------
*
* TclNRCoroutineActivateCallback --
*
* This is the workhorse for coroutines: it implements both yield and
* resume.
*
* It is important that both be implemented in the same callback: the
* detection of the impossibility to suspend due to a busy C-stack relies
* on the precise position of a local variable in the stack. We do not
* want the compiler to play tricks on us, either by moving things around
* or inlining.
*
*----------------------------------------------------------------------
*/
int
TclNRCoroutineActivateCallback(
void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
void *stackLevel = TclGetCStackPtr();
if (!corPtr->stackLevel) {
/*
* -- Coroutine is suspended --
* Push the callback to restore the caller's context on yield or
* return.
*/
TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
NULL, NULL, NULL);
/*
* Record the stackLevel at which the resume is happening, then swap
* the interp's environment to make it suitable to run this coroutine.
*/
corPtr->stackLevel = stackLevel;
Tcl_Size numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = iPtr->numLevels;
SAVE_CONTEXT(corPtr->caller);
corPtr->callerEEPtr = iPtr->execEnvPtr;
RESTORE_CONTEXT(corPtr->running);
iPtr->execEnvPtr = corPtr->eePtr;
iPtr->numLevels += numLevels;
} else {
/*
* Coroutine is active: yield
*/
if (corPtr->stackLevel != stackLevel) {
NRE_callback *runPtr;
iPtr->execEnvPtr = corPtr->callerEEPtr;
if (corPtr->yieldPtr) {
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
if (runPtr->data[1] == corPtr->yieldPtr) {
Tcl_DecrRefCount((Tcl_Obj *)runPtr->data[1]);
runPtr->data[1] = NULL;
corPtr->yieldPtr = NULL;
break;
}
}
}
iPtr->execEnvPtr = corPtr->eePtr;
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot yield: C stack busy", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
(char *)NULL);
return TCL_ERROR;
}
void *type = data[1];
if (type == CORO_ACTIVATE_YIELD) {
corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
} else if (type == CORO_ACTIVATE_YIELDM) {
corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY;
} else {
Tcl_Panic("Yield received an option which is not implemented");
}
corPtr->yieldPtr = NULL;
corPtr->stackLevel = NULL;
Tcl_Size numLevels = iPtr->numLevels;
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
iPtr->execEnvPtr = corPtr->callerEEPtr;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* CoroTypeObjCmd --
*
* Implementation of [::tcl::unsupported::corotype] command.
*
*----------------------------------------------------------------------
*/
static int
CoroTypeObjCmd(
TCL_UNUSED(void *),
|
| ︙ | ︙ | |||
9312 9313 9314 9315 9316 9317 9318 |
/*
* Look up the coroutine.
*/
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
| | | | | | | | | | | | | | | | | | | | | | 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 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 |
/*
* Look up the coroutine.
*/
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only get coroutine type of a coroutine", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objv[1]), (char *)NULL);
return TCL_ERROR;
}
/*
* An active coroutine is "active". Can't tell what it might do in the
* future.
*/
corPtr = (CoroutineData *)cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("active", TCL_INDEX_NONE));
return TCL_OK;
}
/*
* Inactive coroutines are classified by the (effective) command used to
* suspend them, which matters when you're injecting a probe.
*/
switch (corPtr->nargs) {
case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", TCL_INDEX_NONE));
return TCL_OK;
case COROUTINE_ARGUMENTS_ARBITRARY:
Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", TCL_INDEX_NONE));
return TCL_OK;
default:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown coroutine type", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (char *)NULL);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd --
*
* Implementation of [coroinject] and [coroprobe] commands.
*
*----------------------------------------------------------------------
*/
static inline CoroutineData *
GetCoroutineFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const char *errMsg)
{
/*
* How to get a coroutine from its handle.
*/
Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objPtr), (char *)NULL);
return NULL;
}
return (CoroutineData *)cmdPtr->objClientData;
}
static int
TclNRCoroInjectObjCmd(
TCL_UNUSED(void *),
|
| ︙ | ︙ | |||
9401 9402 9403 9404 9405 9406 9407 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
return TCL_ERROR;
}
corPtr = GetCoroutineFromObj(interp, objv[1],
| | | | | | | | | 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 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
return TCL_ERROR;
}
corPtr = GetCoroutineFromObj(interp, objv[1],
"can only inject a command into a coroutine");
if (!corPtr) {
return TCL_ERROR;
}
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only inject a command into a suspended coroutine", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL);
return TCL_ERROR;
}
/*
* Add the callback to the coro's execEnv, so that it is the first thing
* to happen when the coro is resumed.
*/
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, InjectHandler, corPtr,
Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
|
| ︙ | ︙ | |||
9446 9447 9448 9449 9450 9451 9452 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
return TCL_ERROR;
}
corPtr = GetCoroutineFromObj(interp, objv[1],
| | | | | | | | | | | 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 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
return TCL_ERROR;
}
corPtr = GetCoroutineFromObj(interp, objv[1],
"can only inject a probe command into a coroutine");
if (!corPtr) {
return TCL_ERROR;
}
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only inject a probe command into a suspended coroutine",
TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL);
return TCL_ERROR;
}
/*
* Add the callback to the coro's execEnv, so that it is the first thing
* to happen when the coro is resumed.
*/
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, InjectHandler, corPtr,
Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
iPtr->execEnvPtr = savedEEPtr;
/*
* Now we immediately transfer control to the coroutine to run our probe.
* TRICKY STUFF copied from the [yield] implementation.
*
* Push the callback to restore the caller's context on yield back.
*/
TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
NULL, NULL, NULL);
/*
* Record the stackLevel at which the resume is happening, then swap
* the interp's environment to make it suitable to run this coroutine.
*/
corPtr->stackLevel = &corPtr;
|
| ︙ | ︙ | |||
9505 9506 9507 9508 9509 9510 9511 | } /* *---------------------------------------------------------------------- * * InjectHandler, InjectHandlerPostProc -- * | | | | | | | | | | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* InjectHandler, InjectHandlerPostProc --
*
* Part of the implementation of [coroinject] and [coroprobe]. These are
* run inside the context of the coroutine being injected/probed into.
*
* InjectHandler runs a script (possibly adding arguments) in the context
* of the coroutine. The script is specified as a one-shot list (with
* reference count equal to 1) in data[1]. This function also arranges
* for InjectHandlerPostProc to be the part that runs after the script
* completes.
*
* InjectHandlerPostProc cleans up after InjectHandler (deleting the
* list) and, for the [coroprobe] command *only*, yields back to the
* caller context (i.e., where [coroprobe] was run).
*s
*----------------------------------------------------------------------
*/
static int
InjectHandler(
void *data[],
|
| ︙ | ︙ | |||
9563 9564 9565 9566 9567 9568 9569 |
/*
* Call the user's script; we're in the right place.
*/
Tcl_IncrRefCount(listPtr);
TclMarkTailcall(interp);
TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
| | | | 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 |
/*
* Call the user's script; we're in the right place.
*/
Tcl_IncrRefCount(listPtr);
TclMarkTailcall(interp);
TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
INT2PTR(nargs), isProbe);
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
static int
InjectHandlerPostCall(
void *data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
9593 9594 9595 9596 9597 9598 9599 |
* If we were doing a probe, splice ourselves back out of the stack
* cleanly here. General injection should instead just look after itself.
*
* Code from guts of [yield] implementation.
*/
if (isProbe) {
| | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 |
* If we were doing a probe, splice ourselves back out of the stack
* cleanly here. General injection should instead just look after itself.
*
* Code from guts of [yield] implementation.
*/
if (isProbe) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp,
"\n (injected coroutine probe command)");
}
corPtr->nargs = nargs;
corPtr->stackLevel = NULL;
Tcl_Size numLevels = iPtr->numLevels;
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
iPtr->execEnvPtr = corPtr->callerEEPtr;
}
return result;
}
int
TclNRInterpCoroutine(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
CoroutineData *corPtr = (CoroutineData *)clientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", (char *)NULL);
return TCL_ERROR;
}
/*
* Parse all the arguments to work out what to feed as the result of the
* [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine
* is deleted!
*/
switch (corPtr->nargs) {
case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
if (objc == 2) {
Tcl_SetObjResult(interp, objv[1]);
} else if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
return TCL_ERROR;
}
break;
default:
if (corPtr->nargs + 1 != objc) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("wrong coro nargs; how did we get here? "
"not implemented!", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL);
return TCL_ERROR;
}
/* fallthrough */
case COROUTINE_ARGUMENTS_ARBITRARY:
if (objc > 1) {
Tcl_SetObjResult(interp, Tcl_NewListObj(objc - 1, objv + 1));
}
break;
}
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
NULL, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclNRCoroutineObjCmd --
*
* Implementation of [coroutine] command; see documentation for
* description of what this does.
*
*----------------------------------------------------------------------
*/
int
TclNRCoroutineObjCmd(
TCL_UNUSED(void *),
|
| ︙ | ︙ | |||
9751 9752 9753 9754 9755 9756 9757 |
procName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, procName, inNsPtr, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | | | | | 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 |
procName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, procName, inNsPtr, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", (char *)NULL);
return TCL_ERROR;
}
if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, (char *)NULL);
return TCL_ERROR;
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
corPtr = (CoroutineData *)Tcl_Alloc(sizeof(CoroutineData));
cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
(Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
/*
* #280.
* Provide the new coroutine with its own copy of the lineLABCPtr
* hashtable for literal command arguments in bytecode. Note that
* CFWordBC chains are not duplicated, only the entrypoints to them. This
* means that in the presence of coroutines each chain is potentially a
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
|
| ︙ | ︙ | |||
9852 9853 9854 9855 9856 9857 9858 |
iPtr->execEnvPtr = corPtr->callerEEPtr;
/*
* Now just resume the coroutine.
*/
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
| | | 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 9775 9776 |
iPtr->execEnvPtr = corPtr->callerEEPtr;
/*
* Now just resume the coroutine.
*/
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
NULL, NULL, NULL);
return TCL_OK;
}
/*
* This is used in the [info] ensemble
*/
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes))
#define BYTEARRAY_SIZE(len) \
| | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes))
#define BYTEARRAY_SIZE(len) \
( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \
: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
(irPtr)->twoPtrValue.ptr1 = (baPtr)
int
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | * * Tcl_NewByteArrayObj -- * * This procedure is creates a new ByteArray object and initializes it * from the given array of bytes. * * Results: | | | > | 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 |
*
* Tcl_NewByteArrayObj --
*
* This procedure is creates a new ByteArray object and initializes it
* from the given array of bytes.
*
* Results:
* The newly created object is returned. This object has no initial
* string representation. The returned object has a ref count of 0.
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
*----------------------------------------------------------------------
*/
#undef Tcl_NewByteArrayObj
Tcl_Obj *
Tcl_NewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
Tcl_Size numBytes) /* Number of bytes in the array,
* must be >= 0. */
{
#ifdef TCL_MEM_DEBUG
return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0);
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *objPtr;
TclNewObj(objPtr);
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
| | > | > | 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 |
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
Tcl_Size numBytes, /* Number of bytes in the array,
* must be >= 0. */
const char *file, /* The name of the source file calling this
* procedure; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetByteArrayObj(objPtr, bytes, numBytes);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
Tcl_Size numBytes, /* Number of bytes in the array,
* must be >= 0. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewByteArrayObj(bytes, numBytes);
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
310 311 312 313 314 315 316 |
*/
void
Tcl_SetByteArrayObj(
Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
const unsigned char *bytes, /* The array of bytes to use as the new value.
* May be NULL even if numBytes > 0. */
| | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
*/
void
Tcl_SetByteArrayObj(
Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
const unsigned char *bytes, /* The array of bytes to use as the new value.
* May be NULL even if numBytes > 0. */
Tcl_Size numBytes) /* Number of bytes in the array,
* must be >= 0 */
{
ByteArray *byteArrayPtr;
Tcl_ObjInternalRep ir;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 |
if (numBytes > INT_MAX) {
/* Caller asked for numBytes to be written to an int, but the
* value is outside the int range. */
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"byte sequence length exceeds INT_MAX", -1));
| | | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
if (numBytes > INT_MAX) {
/* Caller asked for numBytes to be written to an int, but the
* value is outside the int range. */
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"byte sequence length exceeds INT_MAX", -1));
Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", (char *)NULL);
}
return NULL;
} else {
*(int *)numBytesPtr = (int) numBytes;
}
}
return bytes;
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 |
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
Tcl_Size numBytes) /* Number of bytes in resized array
| | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
Tcl_Size numBytes) /* Number of bytes in resized array
* Must be >= 0 */
{
ByteArray *byteArrayPtr;
Tcl_ObjInternalRep *irPtr;
assert(numBytes >= 0);
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 |
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size limit,
int demandProper,
ByteArray **byteArrayPtrPtr)
{
Tcl_Size length;
| | | | | 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 |
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size limit,
int demandProper,
ByteArray **byteArrayPtrPtr)
{
Tcl_Size length;
const char *src = TclGetStringFromObj(objPtr, &length);
Tcl_Size numBytes = (limit >= 0 && limit < length) ? limit : length;
ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes));
unsigned char *dst = byteArrayPtr->bytes;
unsigned char *dstEnd = dst + numBytes;
const char *srcEnd = src + length;
int proper = 1;
for (; src < srcEnd && dst < dstEnd; ) {
int ch;
int count = TclUtfToUniChar(src, &ch);
if (ch > 255) {
proper = 0;
if (demandProper) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected byte sequence but character %"
TCL_Z_MODIFIER "u was '%1s' (U+%06X)",
dst - byteArrayPtr->bytes, src, ch));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (char *)NULL);
}
Tcl_Free(byteArrayPtr);
*byteArrayPtrPtr = NULL;
return proper;
}
}
src += count;
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
}
SET_BYTEARRAY(&ir, byteArrayPtr);
Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir);
}
Tcl_IncrRefCount(objPtr);
return objPtr;
}
| < | 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
}
SET_BYTEARRAY(&ir, byteArrayPtr);
Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir);
}
Tcl_IncrRefCount(objPtr);
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* SetByteArrayFromAny --
*
* Generate the ByteArray internal rep from the string rep.
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 | Tcl_Size listc; Tcl_Obj **listv; /* * The macro evals its args more than once: avoid arg++ */ | | < | | 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 |
Tcl_Size listc;
Tcl_Obj **listv;
/*
* The macro evals its args more than once: avoid arg++
*/
if (TclListObjLength(interp, objv[arg], &listc) != TCL_OK) {
return TCL_ERROR;
}
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number of elements in list does not match count",
-1));
return TCL_ERROR;
}
if (TclListObjGetElements(interp, objv[arg], &listc,
&listv) != TCL_OK) {
return TCL_ERROR;
}
arg++;
}
offset += count*size;
break;
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
Tcl_DecrRefCount(copy);
break;
}
case 'b':
case 'B': {
unsigned char *last;
| | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
Tcl_DecrRefCount(copy);
break;
}
case 'b':
case 'B': {
unsigned char *last;
str = TclGetStringFromObj(objv[arg], &length);
arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
last = cursor + ((count + 7) / 8);
|
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 |
break;
}
case 'h':
case 'H': {
unsigned char *last;
int c;
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
break;
}
case 'h':
case 'H': {
unsigned char *last;
int c;
str = TclGetStringFromObj(objv[arg], &length);
arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
last = cursor + ((count + 1) / 2);
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 |
* this is safe since we aren't going to modify the array.
*/
listv = (Tcl_Obj **) (objv + arg);
listc = 1;
count = 1;
} else {
| | | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 |
* this is safe since we aren't going to modify the array.
*/
listv = (Tcl_Obj **) (objv + arg);
listc = 1;
count = 1;
} else {
TclListObjGetElements(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
}
arg++;
for (i = 0; i < count; i++) {
if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) {
|
| ︙ | ︙ | |||
1401 1402 1403 1404 1405 1406 1407 |
}
if (count == BINARY_ALL) {
count = length - offset;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 |
}
if (count == BINARY_ALL) {
count = length - offset;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if (count > (length - offset)) {
goto done;
}
}
src = buffer + offset;
size = count;
|
| ︙ | ︙ | |||
1599 1600 1601 1602 1603 1604 1605 |
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
| | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 |
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
if (length < (size + offset)) {
goto done;
}
valuePtr = ScanNumber(buffer+offset, cmd, flags,
&numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
|
| ︙ | ︙ | |||
2394 2395 2396 2397 2398 2399 2400 | } /* * ---------------------------------------------------------------------- * * NOTES -- * | | | 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 | } /* * ---------------------------------------------------------------------- * * NOTES -- * * Some measurements show that it is faster to use a table to perform * uuencode and base64 value encoding than to calculate the output (at * least on intel P4 arch). * * Conversely using a lookup table for the decoding is slower than just * calculating the values. We therefore use the fastest of each method. * * Presumably this has to do with the size of the tables. The base64 |
| ︙ | ︙ | |||
2507 2508 2509 2510 2511 2512 2513 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
| | | 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *)TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = (count + 1) / 2;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
value = 0;
|
| ︙ | ︙ | |||
2557 2558 2559 2560 2561 2562 2563 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
badChar:
if (pure) {
ucs4 = c;
} else {
| | | | 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
badChar:
if (pure) {
ucs4 = c;
} else {
TclUtfToUniChar((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hexadecimal digit \"%c\" (U+%06X) at position %"
TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* BinaryEncode64 --
|
| ︙ | ︙ | |||
2632 2633 2634 2635 2636 2637 2638 |
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",
| | | | 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 |
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", (char *)NULL);
return TCL_ERROR;
}
break;
case OPT_WRAPCHAR:
wrapchar = (const char *)Tcl_GetBytesFromObj(NULL,
objv[i + 1], &wrapcharlen);
if (wrapchar == NULL) {
purewrap = 0;
wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
}
if (wrapcharlen == 0) {
maxlen = 0;
}
|
| ︙ | ︙ | |||
2760 2761 2762 2763 2764 2765 2766 |
&lineLength) != TCL_OK) {
return TCL_ERROR;
}
if (lineLength < 5 || lineLength > 85) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
| | | | 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 |
&lineLength) != TCL_OK) {
return TCL_ERROR;
}
if (lineLength < 5 || lineLength > 85) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", (char *)NULL);
return TCL_ERROR;
}
lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
break;
case OPT_WRAPCHAR:
wrapchar = (const unsigned char *)TclGetStringFromObj(
objv[i + 1], &wrapcharlen);
{
const unsigned char *p = wrapchar;
Tcl_Size numBytes = wrapcharlen;
while (numBytes) {
switch (*p) {
|
| ︙ | ︙ | |||
2789 2790 2791 2792 2793 2794 2795 | break; default: badwrap: Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid wrapchar; will defeat decoding", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", | | | 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 |
break;
default:
badwrap:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invalid wrapchar; will defeat decoding",
-1));
Tcl_SetErrorCode(interp, "TCL", "BINARY",
"ENCODE", "WRAPCHAR", (char *)NULL);
return TCL_ERROR;
}
}
if (numBytes) {
goto badwrap;
}
}
|
| ︙ | ︙ | |||
2911 2912 2913 2914 2915 2916 2917 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
| | | 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
lineLen = -1;
|
| ︙ | ︙ | |||
3014 3015 3016 3017 3018 3019 3020 |
}
Tcl_SetByteArrayLength(resultObj, cursor - begin);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
| | | | | 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 |
}
Tcl_SetByteArrayLength(resultObj, cursor - begin);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", (char *)NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
if (pure) {
ucs4 = c;
} else {
TclUtfToUniChar((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" (U+%06X) at position %"
TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3086 3087 3088 3089 3090 3091 3092 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
| | | 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
unsigned long value = 0;
|
| ︙ | ︙ | |||
3197 3198 3199 3200 3201 3202 3203 |
ucs4 = c;
} else {
/* The decoder is byte-oriented. If we saw a byte that's not a
* valid member of the base64 alphabet, it could be the lead byte
* of a multi-byte character. */
/* Safe because we know data is NUL-terminated */
| | | | 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 |
ucs4 = c;
} else {
/* The decoder is byte-oriented. If we saw a byte that's not a
* valid member of the base64 alphabet, it could be the lead byte
* of a multi-byte character. */
/* Safe because we know data is NUL-terminated */
TclUtfToUniChar((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid base64 character \"%c\" (U+%06X) at position %"
TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
TclDumpMemoryInfo(
void *clientData,
int flags)
{
char buf[1024];
if (clientData == NULL) {
| | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
TclDumpMemoryInfo(
void *clientData,
int flags)
{
char buf[1024];
if (clientData == NULL) {
return 0;
}
snprintf(buf, sizeof(buf),
"total mallocs %10" TCL_Z_MODIFIER "u\n"
"total frees %10" TCL_Z_MODIFIER "u\n"
"current packets allocated %10" TCL_Z_MODIFIER "u\n"
"current bytes allocated %10" TCL_Z_MODIFIER "u\n"
"maximum packets allocated %10" TCL_Z_MODIFIER "u\n"
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
| | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
byte = hiPtr[idx];
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
fprintf(stderr, "hi guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
|
| ︙ | ︙ | |||
715 716 717 718 719 720 721 |
if (newPtr == NULL) {
return NULL;
}
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
| < | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
if (newPtr == NULL) {
return NULL;
}
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Alloc, et al. --
*
* These functions are defined in terms of the debugging versions when
|
| ︙ | ︙ | |||
823 824 825 826 827 828 829 |
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
| | | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) {
Tcl_WideInt value;
if (objc != 3) {
|
| ︙ | ︙ | |||
868 869 870 871 872 873 874 |
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot open output file: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
goto bad_suboption;
}
validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
goto bad_suboption;
}
validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
TclGetString(objv[1])));
return TCL_ERROR;
argError:
Tcl_WrongNumArgs(interp, 2, objv, "count");
return TCL_ERROR;
bad_suboption:
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
* added */
{
TclInitDbCkalloc();
Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
| < < | 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 |
* added */
{
TclInitDbCkalloc();
Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
#else /* TCL_MEM_DEBUG */
/* This is the !TCL_MEM_DEBUG case */
#undef Tcl_InitMemory
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
/*
*----------------------------------------------------------------------
*
* Tcl_Alloc --
*
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
|
| ︙ | ︙ | |||
1249 1250 1251 1252 1253 1254 1255 | * Panics if memory of at least the requested size could not be * allocated. * *------------------------------------------------------------------------ */ void * TclAllocElemsEx( | | | | | | | | | | | | | | | 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 |
* Panics if memory of at least the requested size could not be
* allocated.
*
*------------------------------------------------------------------------
*/
void *
TclAllocElemsEx(
Tcl_Size elemCount, /* Allocation will store at least these many... */
Tcl_Size elemSize, /* ...elements of this size */
Tcl_Size leadSize, /* Additional leading space in bytes */
Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored here if
* non-NULL. Only modified on success */
{
void *ptr = TclAttemptReallocElemsEx(
NULL, elemCount, elemSize, leadSize, capacityPtr);
if (ptr == NULL) {
Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER
"d elements of size %" TCL_SIZE_MODIFIER "d bytes.",
elemCount,
elemSize);
}
return ptr;
}
/*
*------------------------------------------------------------------------
*
* TclAttemptReallocElemsEx --
*
* Attempts to allocate (oldPtr == NULL) or reallocate memory of the
* requested size plus some more for future growth. The amount of
* reallocation is adjusted depending on failure.
*
*
* Results:
* Pointer to allocated memory block which is at least as large
* as the requested size or NULL if allocation failed.
*
*------------------------------------------------------------------------
*/
void *
TclAttemptReallocElemsEx(
void *oldPtr, /* Pointer to memory block to reallocate or
* NULL to indicate this is a new allocation */
Tcl_Size elemCount, /* Allocation will store at least these many... */
Tcl_Size elemSize, /* ...elements of this size */
Tcl_Size leadSize, /* Additional leading space in bytes */
Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored here if
* non-NULL. Only modified on success */
{
void *ptr;
Tcl_Size limit;
Tcl_Size attempt;
assert(elemCount > 0);
assert(elemSize > 0);
|
| ︙ | ︙ | |||
1354 1355 1356 1357 1358 1359 1360 | * Panics if memory of at least the requested size could not be * allocated. * *------------------------------------------------------------------------ */ void * TclReallocElemsEx( | | | | | | | | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 |
* Panics if memory of at least the requested size could not be
* allocated.
*
*------------------------------------------------------------------------
*/
void *
TclReallocElemsEx(
void *oldPtr, /* Pointer to memory block to reallocate */
Tcl_Size elemCount, /* Allocation will store at least these many... */
Tcl_Size elemSize, /* ...elements of this size */
Tcl_Size leadSize, /* Additional leading space in bytes */
Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored here if
* non-NULL. Only modified on success */
{
void *ptr = TclAttemptReallocElemsEx(
oldPtr, elemCount, elemSize, leadSize, capacityPtr);
if (ptr == NULL) {
Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER
"d elements of size %" TCL_SIZE_MODIFIER "d bytes.",
elemCount,
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclClock.c -- * * Contains the time and date related commands. This code is derived from * the time and date facilities of TclX, by Mark Diekhans and Karl * Lehenbauer. * * Copyright © 1991-1995 Karl Lehenbauer & Mark Diekhans. * Copyright © 1995 Sun Microsystems, Inc. * Copyright © 2004 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. */ #include "tclInt.h" #include "tclTomMath.h" | > | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | < < | < | < < < > < < < < < < < < < < < < < < < < < < < < < | > | | | > | < < < < | | | > > > | | | | > > | | | > > > > > | > > | | > | > > > > > > | > > | > | | | | | | < > | | 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 |
/*
* tclClock.c --
*
* Contains the time and date related commands. This code is derived from
* the time and date facilities of TclX, by Mark Diekhans and Karl
* Lehenbauer.
*
* Copyright © 1991-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright © 1995 Sun Microsystems, Inc.
* Copyright © 2004 Kevin B. Kenny. All rights reserved.
* Copyright © 2015 Sergey G. Brester aka sebres. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
#include "tclStrIdxTree.h"
#include "tclDate.h"
/*
* Table of the days in each month, leap and common years
*/
static const int hath[2][12] = {
{31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31},
{31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}
};
static const int daysInPriorMonths[2][13] = {
{0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365},
{0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366}
};
/*
* Enumeration of the string literals used in [clock]
*/
CLOCK_LITERAL_ARRAY(Literals);
/* Msgcat literals for exact match (mcKey) */
CLOCK_LOCALE_LITERAL_ARRAY(MsgCtLiterals, "");
/* Msgcat index literals prefixed with _IDX_, used for quick dictionary search */
CLOCK_LOCALE_LITERAL_ARRAY(MsgCtLitIdxs, "_IDX_");
static const char *const eras[] = { "CE", "BCE", NULL };
/*
* Thread specific data block holding a 'struct tm' for the 'gmtime' and
* 'localtime' library calls.
*/
static Tcl_ThreadDataKey tmKey;
/*
* Mutex protecting 'gmtime', 'localtime' and 'mktime' calls and the statics
* in the date parsing code.
*/
TCL_DECLARE_MUTEX(clockMutex)
/*
* Function prototypes for local procedures in this file:
*/
static int ConvertUTCToLocalUsingTable(Tcl_Interp *,
TclDateFields *, Tcl_Size, Tcl_Obj *const[],
Tcl_WideInt *rangesVal);
static int ConvertUTCToLocalUsingC(Tcl_Interp *,
TclDateFields *, int);
static int ConvertLocalToUTC(ClockClientData *, Tcl_Interp *,
TclDateFields *, Tcl_Obj *timezoneObj, int);
static int ConvertLocalToUTCUsingTable(Tcl_Interp *,
TclDateFields *, int, Tcl_Obj *const[],
Tcl_WideInt *rangesVal);
static int ConvertLocalToUTCUsingC(Tcl_Interp *,
TclDateFields *, int);
static Tcl_ObjCmdProc ClockConfigureObjCmd;
static void GetYearWeekDay(TclDateFields *, int);
static void GetGregorianEraYearDay(TclDateFields *, int);
static void GetMonthDay(TclDateFields *);
static Tcl_WideInt WeekdayOnOrBefore(int, Tcl_WideInt);
static Tcl_ObjCmdProc ClockClicksObjCmd;
static Tcl_ObjCmdProc ClockConvertlocaltoutcObjCmd;
static int ClockGetDateFields(ClockClientData *,
Tcl_Interp *interp, TclDateFields *fields,
Tcl_Obj *timezoneObj, int changeover);
static Tcl_ObjCmdProc ClockGetdatefieldsObjCmd;
static Tcl_ObjCmdProc ClockGetjuliandayfromerayearmonthdayObjCmd;
static Tcl_ObjCmdProc ClockGetjuliandayfromerayearweekdayObjCmd;
static Tcl_ObjCmdProc ClockGetenvObjCmd;
static Tcl_ObjCmdProc ClockMicrosecondsObjCmd;
static Tcl_ObjCmdProc ClockMillisecondsObjCmd;
static Tcl_ObjCmdProc ClockSecondsObjCmd;
static Tcl_ObjCmdProc ClockFormatObjCmd;
static Tcl_ObjCmdProc ClockScanObjCmd;
static int ClockScanCommit(DateInfo *info,
ClockFmtScnCmdArgs *opts);
static int ClockFreeScan(DateInfo *info,
Tcl_Obj *strObj, ClockFmtScnCmdArgs *opts);
static int ClockCalcRelTime(DateInfo *info);
static Tcl_ObjCmdProc ClockAddObjCmd;
static int ClockValidDate(DateInfo *,
ClockFmtScnCmdArgs *, int stage);
static struct tm * ThreadSafeLocalTime(const time_t *);
static size_t TzsetIfNecessary(void);
static void ClockDeleteCmdProc(void *);
static Tcl_ObjCmdProc ClockSafeCatchCmd;
static void ClockFinalize(void *);
/*
* Structure containing description of "native" clock commands to create.
*/
struct ClockCommand {
const char *name; /* The tail of the command name. The full name
* is "::tcl::clock::<name>". When NULL marks
* the end of the table. */
Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
* will always have the ClockClientData sent
* to it, but may well ignore this data. */
CompileProc *compileProc; /* The compiler for the command. */
void *clientData; /* Any clientData to give the command (if NULL
* a reference to ClockClientData will be sent) */
};
static const struct ClockCommand clockCommands[] = {
{"add", ClockAddObjCmd, TclCompileBasicMin1ArgCmd, NULL},
{"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL},
{"format", ClockFormatObjCmd, TclCompileBasicMin1ArgCmd, NULL},
{"getenv", ClockGetenvObjCmd, TclCompileBasicMin1ArgCmd, NULL},
{"microseconds", ClockMicrosecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(1)},
{"milliseconds", ClockMillisecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(2)},
{"scan", ClockScanObjCmd, TclCompileBasicMin1ArgCmd, NULL},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, INT2PTR(3)},
{"ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd, NULL, NULL},
{"GetDateFields", ClockGetdatefieldsObjCmd, NULL, NULL},
{"GetJulianDayFromEraYearMonthDay",
ClockGetjuliandayfromerayearmonthdayObjCmd, NULL, NULL},
{"GetJulianDayFromEraYearWeekDay",
ClockGetjuliandayfromerayearweekdayObjCmd, NULL, NULL},
{"catch", ClockSafeCatchCmd, TclCompileBasicMin1ArgCmd, NULL},
{NULL, NULL, NULL, NULL}
};
/*
*----------------------------------------------------------------------
*
* TclClockInit --
*
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 230 231 232 |
TclClockInit(
Tcl_Interp *interp) /* Tcl interpreter */
{
const struct ClockCommand *clockCmdPtr;
char cmdName[50]; /* Buffer large enough to hold the string
*::tcl::clock::GetJulianDayFromEraYearMonthDay
* plus a terminating NUL. */
ClockClientData *data;
int i;
| > > > | > > > > | < < < < < < < < < < | > > > > > > > > > > > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > < > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | < > | | | | < | | | | | < | | | > > | | < < > | < < < < | < < < < < < < < < < < | 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 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 |
TclClockInit(
Tcl_Interp *interp) /* Tcl interpreter */
{
const struct ClockCommand *clockCmdPtr;
char cmdName[50]; /* Buffer large enough to hold the string
*::tcl::clock::GetJulianDayFromEraYearMonthDay
* plus a terminating NUL. */
Command *cmdPtr;
ClockClientData *data;
int i;
static int initialized = 0; /* global clock engine initialized (in process) */
/*
* Register handler to finalize clock on exit.
*/
if (!initialized) {
Tcl_CreateExitHandler(ClockFinalize, NULL);
initialized = 1;
}
/*
* Safe interps get [::clock] as alias to a parent, so do not need their
* own copies of the support routines.
*/
if (Tcl_IsSafe(interp)) {
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
data = (ClockClientData *)Tcl_Alloc(sizeof(ClockClientData));
data->refCount = 0;
data->literals = (Tcl_Obj **)Tcl_Alloc(LIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < LIT__END; ++i) {
TclInitObjRef(data->literals[i], Tcl_NewStringObj(
Literals[i], TCL_AUTO_LENGTH));
}
data->mcLiterals = NULL;
data->mcLitIdxs = NULL;
data->mcDicts = NULL;
data->lastTZEpoch = 0;
data->currentYearCentury = ClockDefaultYearCentury;
data->yearOfCenturySwitch = ClockDefaultCenturySwitch;
data->validMinYear = INT_MIN;
data->validMaxYear = INT_MAX;
/* corresponds max of JDN in sqlite - 9999-12-31 23:59:59 per default */
data->maxJDN = 5373484.499999994;
data->systemTimeZone = NULL;
data->systemSetupTZData = NULL;
data->gmtSetupTimeZoneUnnorm = NULL;
data->gmtSetupTimeZone = NULL;
data->gmtSetupTZData = NULL;
data->gmtTZName = NULL;
data->lastSetupTimeZoneUnnorm = NULL;
data->lastSetupTimeZone = NULL;
data->lastSetupTZData = NULL;
data->prevSetupTimeZoneUnnorm = NULL;
data->prevSetupTimeZone = NULL;
data->prevSetupTZData = NULL;
data->defaultLocale = NULL;
data->defaultLocaleDict = NULL;
data->currentLocale = NULL;
data->currentLocaleDict = NULL;
data->lastUsedLocaleUnnorm = NULL;
data->lastUsedLocale = NULL;
data->lastUsedLocaleDict = NULL;
data->prevUsedLocaleUnnorm = NULL;
data->prevUsedLocale = NULL;
data->prevUsedLocaleDict = NULL;
data->lastBase.timezoneObj = NULL;
memset(&data->lastTZOffsCache, 0, sizeof(data->lastTZOffsCache));
data->defFlags = CLF_VALIDATE;
/*
* Install the commands.
*/
#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN);
for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
void *clientData;
strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
if (!(clientData = clockCmdPtr->clientData)) {
clientData = data;
data->refCount++;
}
cmdPtr = (Command *)Tcl_CreateObjCommand(interp, cmdName,
clockCmdPtr->objCmdProc, clientData,
clockCmdPtr->clientData ? NULL : ClockDeleteCmdProc);
cmdPtr->compileProc = clockCmdPtr->compileProc ?
clockCmdPtr->compileProc : TclCompileBasicMin0ArgCmd;
}
cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
"::tcl::unsupported::clock::configure",
ClockConfigureObjCmd, data, ClockDeleteCmdProc);
data->refCount++;
cmdPtr->compileProc = TclCompileBasicMin0ArgCmd;
}
/*
*----------------------------------------------------------------------
*
* ClockConfigureClear --
*
* Clean up cached resp. run-time storages used in clock commands.
*
* Shared usage for clean-up (ClockDeleteCmdProc) and "configure -clear".
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static void
ClockConfigureClear(
ClockClientData *data)
{
ClockFrmScnClearCaches();
data->lastTZEpoch = 0;
TclUnsetObjRef(data->systemTimeZone);
TclUnsetObjRef(data->systemSetupTZData);
TclUnsetObjRef(data->gmtSetupTimeZoneUnnorm);
TclUnsetObjRef(data->gmtSetupTimeZone);
TclUnsetObjRef(data->gmtSetupTZData);
TclUnsetObjRef(data->gmtTZName);
TclUnsetObjRef(data->lastSetupTimeZoneUnnorm);
TclUnsetObjRef(data->lastSetupTimeZone);
TclUnsetObjRef(data->lastSetupTZData);
TclUnsetObjRef(data->prevSetupTimeZoneUnnorm);
TclUnsetObjRef(data->prevSetupTimeZone);
TclUnsetObjRef(data->prevSetupTZData);
TclUnsetObjRef(data->defaultLocale);
data->defaultLocaleDict = NULL;
TclUnsetObjRef(data->currentLocale);
data->currentLocaleDict = NULL;
TclUnsetObjRef(data->lastUsedLocaleUnnorm);
TclUnsetObjRef(data->lastUsedLocale);
data->lastUsedLocaleDict = NULL;
TclUnsetObjRef(data->prevUsedLocaleUnnorm);
TclUnsetObjRef(data->prevUsedLocale);
data->prevUsedLocaleDict = NULL;
TclUnsetObjRef(data->lastBase.timezoneObj);
TclUnsetObjRef(data->lastTZOffsCache[0].timezoneObj);
TclUnsetObjRef(data->lastTZOffsCache[0].tzName);
TclUnsetObjRef(data->lastTZOffsCache[1].timezoneObj);
TclUnsetObjRef(data->lastTZOffsCache[1].tzName);
TclUnsetObjRef(data->mcDicts);
}
/*
*----------------------------------------------------------------------
*
* ClockDeleteCmdProc --
*
* Remove a reference to the clock client data, and clean up memory
* when it's all gone.
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static void
ClockDeleteCmdProc(
void *clientData) /* Opaque pointer to the client data */
{
ClockClientData *data = (ClockClientData *)clientData;
int i;
if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
if (data->mcLiterals != NULL) {
for (i = 0; i < MCLIT__END; ++i) {
Tcl_DecrRefCount(data->mcLiterals[i]);
}
Tcl_Free(data->mcLiterals);
data->mcLiterals = NULL;
}
if (data->mcLitIdxs != NULL) {
for (i = 0; i < MCLIT__END; ++i) {
Tcl_DecrRefCount(data->mcLitIdxs[i]);
}
Tcl_Free(data->mcLitIdxs);
data->mcLitIdxs = NULL;
}
ClockConfigureClear(data);
Tcl_Free(data->literals);
Tcl_Free(data);
}
}
/*
*----------------------------------------------------------------------
*
* SavePrevTimezoneObj --
*
* Used to store previously used/cached time zone (makes it reusable).
*
* This enables faster switch between time zones (e. g. to convert from
* one to another).
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static inline void
SavePrevTimezoneObj(
ClockClientData *dataPtr) /* Client data containing literal pool */
{
Tcl_Obj *timezoneObj = dataPtr->lastSetupTimeZone;
if (timezoneObj && timezoneObj != dataPtr->prevSetupTimeZone) {
TclSetObjRef(dataPtr->prevSetupTimeZoneUnnorm, dataPtr->lastSetupTimeZoneUnnorm);
TclSetObjRef(dataPtr->prevSetupTimeZone, timezoneObj);
TclSetObjRef(dataPtr->prevSetupTZData, dataPtr->lastSetupTZData);
}
}
/*
*----------------------------------------------------------------------
*
* NormTimezoneObj --
*
* Normalizes the timezone object (used for caching puposes).
*
* If already cached time zone could be found, returns this
* object (last setup or last used, system (current) or gmt).
*
* Results:
* Normalized tcl object pointer.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
NormTimezoneObj(
ClockClientData *dataPtr, /* Client data containing literal pool */
Tcl_Obj *timezoneObj, /* Name of zone to find */
int *loaded) /* Used to recognized TZ was loaded */
{
const char *tz;
*loaded = 1;
if (timezoneObj == dataPtr->lastSetupTimeZoneUnnorm
&& dataPtr->lastSetupTimeZone != NULL) {
return dataPtr->lastSetupTimeZone;
}
if (timezoneObj == dataPtr->prevSetupTimeZoneUnnorm
&& dataPtr->prevSetupTimeZone != NULL) {
return dataPtr->prevSetupTimeZone;
}
if (timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm
&& dataPtr->gmtSetupTimeZone != NULL) {
return dataPtr->literals[LIT_GMT];
}
if (timezoneObj == dataPtr->lastSetupTimeZone
|| timezoneObj == dataPtr->prevSetupTimeZone
|| timezoneObj == dataPtr->gmtSetupTimeZone
|| timezoneObj == dataPtr->systemTimeZone) {
return timezoneObj;
}
tz = TclGetString(timezoneObj);
if (dataPtr->lastSetupTimeZone != NULL
&& strcmp(tz, TclGetString(dataPtr->lastSetupTimeZone)) == 0) {
TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, timezoneObj);
return dataPtr->lastSetupTimeZone;
}
if (dataPtr->prevSetupTimeZone != NULL
&& strcmp(tz, TclGetString(dataPtr->prevSetupTimeZone)) == 0) {
TclSetObjRef(dataPtr->prevSetupTimeZoneUnnorm, timezoneObj);
return dataPtr->prevSetupTimeZone;
}
if (dataPtr->systemTimeZone != NULL
&& strcmp(tz, TclGetString(dataPtr->systemTimeZone)) == 0) {
return dataPtr->systemTimeZone;
}
if (strcmp(tz, Literals[LIT_GMT]) == 0) {
TclSetObjRef(dataPtr->gmtSetupTimeZoneUnnorm, timezoneObj);
if (dataPtr->gmtSetupTimeZone == NULL) {
*loaded = 0;
}
return dataPtr->literals[LIT_GMT];
}
/* unknown/unloaded tz - recache/revalidate later as last-setup if needed */
*loaded = 0;
return timezoneObj;
}
/*
*----------------------------------------------------------------------
*
* ClockGetSystemLocale --
*
* Returns system locale.
*
* Executes ::tcl::clock::GetSystemLocale in given interpreter.
*
* Results:
* Returns system locale tcl object.
*
*----------------------------------------------------------------------
*/
static inline Tcl_Obj *
ClockGetSystemLocale(
ClockClientData *dataPtr, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp) /* Tcl interpreter */
{
if (Tcl_EvalObjv(interp, 1, &dataPtr->literals[LIT_GETSYSTEMLOCALE], 0) != TCL_OK) {
return NULL;
}
return Tcl_GetObjResult(interp);
}
/*
*----------------------------------------------------------------------
*
* ClockGetCurrentLocale --
*
* Returns current locale.
*
* Executes ::tcl::clock::mclocale in given interpreter.
*
* Results:
* Returns current locale tcl object.
*
*----------------------------------------------------------------------
*/
static inline Tcl_Obj *
ClockGetCurrentLocale(
ClockClientData *dataPtr, /* Client data containing literal pool */
Tcl_Interp *interp) /* Tcl interpreter */
{
if (Tcl_EvalObjv(interp, 1, &dataPtr->literals[LIT_GETCURRENTLOCALE], 0) != TCL_OK) {
return NULL;
}
TclSetObjRef(dataPtr->currentLocale, Tcl_GetObjResult(interp));
dataPtr->currentLocaleDict = NULL;
Tcl_ResetResult(interp);
return dataPtr->currentLocale;
}
/*
*----------------------------------------------------------------------
*
* SavePrevLocaleObj --
*
* Used to store previously used/cached locale (makes it reusable).
*
* This enables faster switch between locales (e. g. to convert from one to another).
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static inline void
SavePrevLocaleObj(
ClockClientData *dataPtr) /* Client data containing literal pool */
{
Tcl_Obj *localeObj = dataPtr->lastUsedLocale;
if (localeObj && localeObj != dataPtr->prevUsedLocale) {
TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, dataPtr->lastUsedLocaleUnnorm);
TclSetObjRef(dataPtr->prevUsedLocale, localeObj);
/* mcDicts owns reference to dict */
dataPtr->prevUsedLocaleDict = dataPtr->lastUsedLocaleDict;
}
}
/*
*----------------------------------------------------------------------
*
* NormLocaleObj --
*
* Normalizes the locale object (used for caching puposes).
*
* If already cached locale could be found, returns this
* object (current, system (OS) or last used locales).
*
* Results:
* Normalized tcl object pointer.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
NormLocaleObj(
ClockClientData *dataPtr, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *localeObj,
Tcl_Obj **mcDictObj)
{
const char *loc, *loc2;
if (localeObj == NULL
|| localeObj == dataPtr->literals[LIT_C]
|| localeObj == dataPtr->defaultLocale) {
*mcDictObj = dataPtr->defaultLocaleDict;
return dataPtr->defaultLocale ?
dataPtr->defaultLocale : dataPtr->literals[LIT_C];
}
if (localeObj == dataPtr->currentLocale
|| localeObj == dataPtr->literals[LIT_CURRENT]) {
if (dataPtr->currentLocale == NULL) {
ClockGetCurrentLocale(dataPtr, interp);
}
*mcDictObj = dataPtr->currentLocaleDict;
return dataPtr->currentLocale;
}
if (localeObj == dataPtr->lastUsedLocale
|| localeObj == dataPtr->lastUsedLocaleUnnorm) {
*mcDictObj = dataPtr->lastUsedLocaleDict;
return dataPtr->lastUsedLocale;
}
if (localeObj == dataPtr->prevUsedLocale
|| localeObj == dataPtr->prevUsedLocaleUnnorm) {
*mcDictObj = dataPtr->prevUsedLocaleDict;
return dataPtr->prevUsedLocale;
}
loc = TclGetString(localeObj);
if (dataPtr->currentLocale != NULL
&& (localeObj == dataPtr->currentLocale
|| (localeObj->length == dataPtr->currentLocale->length
&& strcasecmp(loc, TclGetString(dataPtr->currentLocale)) == 0))) {
*mcDictObj = dataPtr->currentLocaleDict;
return dataPtr->currentLocale;
}
if (dataPtr->lastUsedLocale != NULL
&& (localeObj == dataPtr->lastUsedLocale
|| (localeObj->length == dataPtr->lastUsedLocale->length
&& strcasecmp(loc, TclGetString(dataPtr->lastUsedLocale)) == 0))) {
*mcDictObj = dataPtr->lastUsedLocaleDict;
TclSetObjRef(dataPtr->lastUsedLocaleUnnorm, localeObj);
return dataPtr->lastUsedLocale;
}
if (dataPtr->prevUsedLocale != NULL
&& (localeObj == dataPtr->prevUsedLocale
|| (localeObj->length == dataPtr->prevUsedLocale->length
&& strcasecmp(loc, TclGetString(dataPtr->prevUsedLocale)) == 0))) {
*mcDictObj = dataPtr->prevUsedLocaleDict;
TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj);
return dataPtr->prevUsedLocale;
}
if ((localeObj->length == 1 /* C */
&& strcasecmp(loc, Literals[LIT_C]) == 0)
|| (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale))
&& localeObj->length == dataPtr->defaultLocale->length
&& strcasecmp(loc, loc2) == 0)) {
*mcDictObj = dataPtr->defaultLocaleDict;
return dataPtr->defaultLocale ?
dataPtr->defaultLocale : dataPtr->literals[LIT_C];
}
if (localeObj->length == 7 /* current */
&& strcasecmp(loc, Literals[LIT_CURRENT]) == 0) {
if (dataPtr->currentLocale == NULL) {
ClockGetCurrentLocale(dataPtr, interp);
}
*mcDictObj = dataPtr->currentLocaleDict;
return dataPtr->currentLocale;
}
if ((localeObj->length == 6 /* system */
&& strcasecmp(loc, Literals[LIT_SYSTEM]) == 0)) {
SavePrevLocaleObj(dataPtr);
TclSetObjRef(dataPtr->lastUsedLocaleUnnorm, localeObj);
localeObj = ClockGetSystemLocale(dataPtr, interp);
TclSetObjRef(dataPtr->lastUsedLocale, localeObj);
*mcDictObj = NULL;
return localeObj;
}
*mcDictObj = NULL;
return localeObj;
}
/*
*----------------------------------------------------------------------
*
* ClockMCDict --
*
* Retrieves a localized storage dictionary object for the given
* locale object.
*
* This corresponds with call `::tcl::clock::mcget locale`.
* Cached representation stored in options (for further access).
*
* Results:
* Tcl-object contains smart reference to msgcat dictionary.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
ClockMCDict(
ClockFmtScnCmdArgs *opts)
{
ClockClientData *dataPtr = opts->dataPtr;
/* if dict not yet retrieved */
if (opts->mcDictObj == NULL) {
/* if locale was not yet used */
if (!(opts->flags & CLF_LOCALE_USED)) {
opts->localeObj = NormLocaleObj(dataPtr, opts->interp,
opts->localeObj, &opts->mcDictObj);
if (opts->localeObj == NULL) {
Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
"locale not specified and no default locale set",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(opts->interp, "CLOCK", "badOption", (char *)NULL);
return NULL;
}
opts->flags |= CLF_LOCALE_USED;
/* check locale literals already available (on demand creation) */
if (dataPtr->mcLiterals == NULL) {
int i;
dataPtr->mcLiterals = (Tcl_Obj **)
Tcl_Alloc(MCLIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < MCLIT__END; ++i) {
TclInitObjRef(dataPtr->mcLiterals[i], Tcl_NewStringObj(
MsgCtLiterals[i], TCL_AUTO_LENGTH));
}
}
}
/* check or obtain mcDictObj (be sure it's modifiable) */
if (opts->mcDictObj == NULL || opts->mcDictObj->refCount > 1) {
Tcl_Size ref = 1;
/* first try to find locale catalog dict */
if (dataPtr->mcDicts == NULL) {
TclSetObjRef(dataPtr->mcDicts, Tcl_NewDictObj());
}
Tcl_DictObjGet(NULL, dataPtr->mcDicts,
opts->localeObj, &opts->mcDictObj);
if (opts->mcDictObj == NULL) {
/* get msgcat dictionary - ::tcl::clock::mcget locale */
Tcl_Obj *callargs[2];
callargs[0] = dataPtr->literals[LIT_MCGET];
callargs[1] = opts->localeObj;
if (Tcl_EvalObjv(opts->interp, 2, callargs, 0) != TCL_OK) {
return NULL;
}
opts->mcDictObj = Tcl_GetObjResult(opts->interp);
Tcl_ResetResult(opts->interp);
ref = 0; /* new object is not yet referenced */
}
/* be sure that object reference doesn't increase (dict changeable) */
if (opts->mcDictObj->refCount > ref) {
/* smart reference (shared dict as object with no ref-counter) */
opts->mcDictObj = TclDictObjSmartRef(opts->interp,
opts->mcDictObj);
}
/* create exactly one reference to catalog / make it searchable for future */
Tcl_DictObjPut(NULL, dataPtr->mcDicts, opts->localeObj,
opts->mcDictObj);
if (opts->localeObj == dataPtr->literals[LIT_C]
|| opts->localeObj == dataPtr->defaultLocale) {
dataPtr->defaultLocaleDict = opts->mcDictObj;
}
if (opts->localeObj == dataPtr->currentLocale) {
dataPtr->currentLocaleDict = opts->mcDictObj;
} else if (opts->localeObj == dataPtr->lastUsedLocale) {
dataPtr->lastUsedLocaleDict = opts->mcDictObj;
} else {
SavePrevLocaleObj(dataPtr);
TclSetObjRef(dataPtr->lastUsedLocale, opts->localeObj);
TclUnsetObjRef(dataPtr->lastUsedLocaleUnnorm);
dataPtr->lastUsedLocaleDict = opts->mcDictObj;
}
}
}
return opts->mcDictObj;
}
/*
*----------------------------------------------------------------------
*
* ClockMCGet --
*
* Retrieves a msgcat value for the given literal integer mcKey
* from localized storage (corresponding given locale object)
* by mcLiterals[mcKey] (e. g. MONTHS_FULL).
*
* Results:
* Tcl-object contains localized value.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
ClockMCGet(
ClockFmtScnCmdArgs *opts,
int mcKey)
{
Tcl_Obj *valObj = NULL;
if (opts->mcDictObj == NULL) {
ClockMCDict(opts);
if (opts->mcDictObj == NULL) {
return NULL;
}
}
Tcl_DictObjGet(opts->interp, opts->mcDictObj,
opts->dataPtr->mcLiterals[mcKey], &valObj);
return valObj; /* or NULL in obscure case if Tcl_DictObjGet failed */
}
/*
*----------------------------------------------------------------------
*
* ClockMCGetIdx --
*
* Retrieves an indexed msgcat value for the given literal integer mcKey
* from localized storage (corresponding given locale object)
* by mcLitIdxs[mcKey] (e. g. _IDX_MONTHS_FULL).
*
* Results:
* Tcl-object contains localized indexed value.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE Tcl_Obj *
ClockMCGetIdx(
ClockFmtScnCmdArgs *opts,
int mcKey)
{
ClockClientData *dataPtr = opts->dataPtr;
Tcl_Obj *valObj = NULL;
if (opts->mcDictObj == NULL) {
ClockMCDict(opts);
if (opts->mcDictObj == NULL) {
return NULL;
}
}
/* try to get indices object */
if (dataPtr->mcLitIdxs == NULL) {
return NULL;
}
if (Tcl_DictObjGet(NULL, opts->mcDictObj,
dataPtr->mcLitIdxs[mcKey], &valObj) != TCL_OK) {
return NULL;
}
return valObj;
}
/*
*----------------------------------------------------------------------
*
* ClockMCSetIdx --
*
* Sets an indexed msgcat value for the given literal integer mcKey
* in localized storage (corresponding given locale object)
* by mcLitIdxs[mcKey] (e. g. _IDX_MONTHS_FULL).
*
* Results:
* Returns a standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
ClockMCSetIdx(
ClockFmtScnCmdArgs *opts,
int mcKey,
Tcl_Obj *valObj)
{
ClockClientData *dataPtr = opts->dataPtr;
if (opts->mcDictObj == NULL) {
ClockMCDict(opts);
if (opts->mcDictObj == NULL) {
return TCL_ERROR;
}
}
/* if literal storage for indices not yet created */
if (dataPtr->mcLitIdxs == NULL) {
int i;
dataPtr->mcLitIdxs = (Tcl_Obj **)Tcl_Alloc(MCLIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < MCLIT__END; ++i) {
TclInitObjRef(dataPtr->mcLitIdxs[i],
Tcl_NewStringObj(MsgCtLitIdxs[i], TCL_AUTO_LENGTH));
}
}
return Tcl_DictObjPut(opts->interp, opts->mcDictObj,
dataPtr->mcLitIdxs[mcKey], valObj);
}
static void
TimezoneLoaded(
ClockClientData *dataPtr,
Tcl_Obj *timezoneObj, /* Name of zone was loaded */
Tcl_Obj *tzUnnormObj) /* Name of zone was loaded */
{
/* don't overwrite last-setup with GMT (special case) */
if (timezoneObj == dataPtr->literals[LIT_GMT]) {
/* mark GMT zone loaded */
if (dataPtr->gmtSetupTimeZone == NULL) {
TclSetObjRef(dataPtr->gmtSetupTimeZone,
dataPtr->literals[LIT_GMT]);
}
TclSetObjRef(dataPtr->gmtSetupTimeZoneUnnorm, tzUnnormObj);
return;
}
/* last setup zone loaded */
if (dataPtr->lastSetupTimeZone != timezoneObj) {
SavePrevTimezoneObj(dataPtr);
TclSetObjRef(dataPtr->lastSetupTimeZone, timezoneObj);
TclUnsetObjRef(dataPtr->lastSetupTZData);
}
TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, tzUnnormObj);
}
/*
*----------------------------------------------------------------------
*
* ClockConfigureObjCmd --
*
* This function is invoked to process the Tcl "::tcl::unsupported::clock::configure"
* (internal, unsupported) command.
*
* Usage:
* ::tcl::unsupported::clock::configure ?-option ?value??
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ClockConfigureObjCmd(
void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
static const char *const options[] = {
"-default-locale", "-clear", "-current-locale",
"-year-century", "-century-switch",
"-min-year", "-max-year", "-max-jdn", "-validate",
"-init-complete", "-setup-tz", "-system-tz", NULL
};
enum optionInd {
CLOCK_DEFAULT_LOCALE, CLOCK_CLEAR_CACHE, CLOCK_CURRENT_LOCALE,
CLOCK_YEAR_CENTURY, CLOCK_CENTURY_SWITCH,
CLOCK_MIN_YEAR, CLOCK_MAX_YEAR, CLOCK_MAX_JDN, CLOCK_VALIDATE,
CLOCK_INIT_COMPLETE, CLOCK_SETUP_TZ, CLOCK_SYSTEM_TZ
};
int optionIndex; /* Index of an option. */
Tcl_Size i;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i++], options,
"option", 0, &optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
TclGetString(objv[i - 1]), (char *)NULL);
return TCL_ERROR;
}
switch (optionIndex) {
case CLOCK_SYSTEM_TZ: {
/* validate current tz-epoch */
size_t lastTZEpoch = TzsetIfNecessary();
if (i < objc) {
if (dataPtr->systemTimeZone != objv[i]) {
TclSetObjRef(dataPtr->systemTimeZone, objv[i]);
TclUnsetObjRef(dataPtr->systemSetupTZData);
}
dataPtr->lastTZEpoch = lastTZEpoch;
}
if (i + 1 >= objc && dataPtr->systemTimeZone != NULL
&& dataPtr->lastTZEpoch == lastTZEpoch) {
Tcl_SetObjResult(interp, dataPtr->systemTimeZone);
}
break;
}
case CLOCK_SETUP_TZ:
if (i < objc) {
int loaded;
Tcl_Obj *timezoneObj = NormTimezoneObj(dataPtr, objv[i], &loaded);
if (!loaded) {
TimezoneLoaded(dataPtr, timezoneObj, objv[i]);
}
Tcl_SetObjResult(interp, timezoneObj);
} else if (i + 1 >= objc && dataPtr->lastSetupTimeZone != NULL) {
Tcl_SetObjResult(interp, dataPtr->lastSetupTimeZone);
}
break;
case CLOCK_DEFAULT_LOCALE:
if (i < objc) {
if (dataPtr->defaultLocale != objv[i]) {
TclSetObjRef(dataPtr->defaultLocale, objv[i]);
dataPtr->defaultLocaleDict = NULL;
}
}
if (i + 1 >= objc) {
Tcl_SetObjResult(interp, dataPtr->defaultLocale ?
dataPtr->defaultLocale : dataPtr->literals[LIT_C]);
}
break;
case CLOCK_CURRENT_LOCALE:
if (i < objc) {
if (dataPtr->currentLocale != objv[i]) {
TclSetObjRef(dataPtr->currentLocale, objv[i]);
dataPtr->currentLocaleDict = NULL;
}
}
if (i + 1 >= objc && dataPtr->currentLocale != NULL) {
Tcl_SetObjResult(interp, dataPtr->currentLocale);
}
break;
case CLOCK_YEAR_CENTURY:
if (i < objc) {
int year;
if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
return TCL_ERROR;
}
dataPtr->currentYearCentury = year;
if (i + 1 >= objc) {
Tcl_SetObjResult(interp, objv[i]);
}
continue;
}
if (i + 1 >= objc) {
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(dataPtr->currentYearCentury));
}
break;
case CLOCK_CENTURY_SWITCH:
if (i < objc) {
int year;
if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
return TCL_ERROR;
}
dataPtr->yearOfCenturySwitch = year;
Tcl_SetObjResult(interp, objv[i]);
continue;
}
if (i + 1 >= objc) {
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(dataPtr->yearOfCenturySwitch));
}
break;
case CLOCK_MIN_YEAR:
if (i < objc) {
int year;
if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
return TCL_ERROR;
}
dataPtr->validMinYear = year;
Tcl_SetObjResult(interp, objv[i]);
continue;
}
if (i + 1 >= objc) {
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(dataPtr->validMinYear));
}
break;
case CLOCK_MAX_YEAR:
if (i < objc) {
int year;
if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
return TCL_ERROR;
}
dataPtr->validMaxYear = year;
Tcl_SetObjResult(interp, objv[i]);
continue;
}
if (i + 1 >= objc) {
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(dataPtr->validMaxYear));
}
break;
case CLOCK_MAX_JDN:
if (i < objc) {
double jd;
if (Tcl_GetDoubleFromObj(interp, objv[i], &jd) != TCL_OK) {
return TCL_ERROR;
}
dataPtr->maxJDN = jd;
Tcl_SetObjResult(interp, objv[i]);
continue;
}
if (i + 1 >= objc) {
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dataPtr->maxJDN));
}
break;
case CLOCK_VALIDATE:
if (i < objc) {
int val;
if (Tcl_GetBooleanFromObj(interp, objv[i], &val) != TCL_OK) {
return TCL_ERROR;
}
if (val) {
dataPtr->defFlags |= CLF_VALIDATE;
} else {
dataPtr->defFlags &= ~CLF_VALIDATE;
}
}
if (i + 1 >= objc) {
Tcl_SetObjResult(interp,
Tcl_NewBooleanObj(dataPtr->defFlags & CLF_VALIDATE));
}
break;
case CLOCK_CLEAR_CACHE:
ClockConfigureClear(dataPtr);
break;
case CLOCK_INIT_COMPLETE: {
/*
* Init completed.
* Compile clock ensemble (performance purposes).
*/
Tcl_Command token = Tcl_FindCommand(interp, "::clock",
NULL, TCL_GLOBAL_ONLY);
if (!token) {
return TCL_ERROR;
}
int ensFlags = 0;
if (Tcl_GetEnsembleFlags(interp, token, &ensFlags) != TCL_OK) {
return TCL_ERROR;
}
ensFlags |= ENSEMBLE_COMPILE;
if (Tcl_SetEnsembleFlags(interp, token, ensFlags) != TCL_OK) {
return TCL_ERROR;
}
break;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ClockGetTZData --
*
* Retrieves tzdata table for given normalized timezone.
*
* Results:
* Returns a tcl object with tzdata.
*
* Side effects:
* The tzdata can be cached in ClockClientData structure.
*
*----------------------------------------------------------------------
*/
static inline Tcl_Obj *
ClockGetTZData(
ClockClientData *dataPtr, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *timezoneObj) /* Name of the timezone */
{
Tcl_Obj *ret, **out = NULL;
/* if cached (if already setup this one) */
if (timezoneObj == dataPtr->lastSetupTimeZone
|| timezoneObj == dataPtr->lastSetupTimeZoneUnnorm) {
if (dataPtr->lastSetupTZData != NULL) {
return dataPtr->lastSetupTZData;
}
out = &dataPtr->lastSetupTZData;
}
/* differentiate GMT and system zones, because used often */
/* simple caching, because almost used the tz-data of last timezone
*/
if (timezoneObj == dataPtr->systemTimeZone) {
if (dataPtr->systemSetupTZData != NULL) {
return dataPtr->systemSetupTZData;
}
out = &dataPtr->systemSetupTZData;
} else if (timezoneObj == dataPtr->literals[LIT_GMT]
|| timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm) {
if (dataPtr->gmtSetupTZData != NULL) {
return dataPtr->gmtSetupTZData;
}
out = &dataPtr->gmtSetupTZData;
} else if (timezoneObj == dataPtr->prevSetupTimeZone
|| timezoneObj == dataPtr->prevSetupTimeZoneUnnorm) {
if (dataPtr->prevSetupTZData != NULL) {
return dataPtr->prevSetupTZData;
}
out = &dataPtr->prevSetupTZData;
}
ret = Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA],
timezoneObj, TCL_LEAVE_ERR_MSG);
/* cache using corresponding slot and as last used */
if (out != NULL) {
TclSetObjRef(*out, ret);
} else if (dataPtr->lastSetupTimeZone != timezoneObj) {
SavePrevTimezoneObj(dataPtr);
TclSetObjRef(dataPtr->lastSetupTimeZone, timezoneObj);
TclUnsetObjRef(dataPtr->lastSetupTimeZoneUnnorm);
TclSetObjRef(dataPtr->lastSetupTZData, ret);
}
return ret;
}
/*
*----------------------------------------------------------------------
*
* ClockGetSystemTimeZone --
*
* Returns system (current) timezone.
*
* If system zone not yet cached, it executes ::tcl::clock::GetSystemTimeZone
* in given interpreter and caches its result.
*
* Results:
* Returns normalized timezone object.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
ClockGetSystemTimeZone(
ClockClientData *dataPtr, /* Pointer to literal pool, etc. */
Tcl_Interp *interp) /* Tcl interpreter */
{
/* if known (cached and same epoch) - return now */
if (dataPtr->systemTimeZone != NULL
&& dataPtr->lastTZEpoch == TzsetIfNecessary()) {
return dataPtr->systemTimeZone;
}
TclUnsetObjRef(dataPtr->systemTimeZone);
TclUnsetObjRef(dataPtr->systemSetupTZData);
if (Tcl_EvalObjv(interp, 1, &dataPtr->literals[LIT_GETSYSTEMTIMEZONE], 0) != TCL_OK) {
return NULL;
}
if (dataPtr->systemTimeZone == NULL) {
TclSetObjRef(dataPtr->systemTimeZone, Tcl_GetObjResult(interp));
}
Tcl_ResetResult(interp);
return dataPtr->systemTimeZone;
}
/*
*----------------------------------------------------------------------
*
* ClockSetupTimeZone --
*
* Sets up the timezone. Loads tzdata, etc.
*
* Results:
* Returns normalized timezone object.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
ClockSetupTimeZone(
ClockClientData *dataPtr, /* Pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *timezoneObj)
{
int loaded;
Tcl_Obj *callargs[2];
/* if cached (if already setup this one) */
if (timezoneObj == dataPtr->literals[LIT_GMT]
&& dataPtr->gmtSetupTZData != NULL) {
return timezoneObj;
}
if ((timezoneObj == dataPtr->lastSetupTimeZone
|| timezoneObj == dataPtr->lastSetupTimeZoneUnnorm)
&& dataPtr->lastSetupTimeZone != NULL) {
return dataPtr->lastSetupTimeZone;
}
if ((timezoneObj == dataPtr->prevSetupTimeZone
|| timezoneObj == dataPtr->prevSetupTimeZoneUnnorm)
&& dataPtr->prevSetupTimeZone != NULL) {
return dataPtr->prevSetupTimeZone;
}
/* differentiate normalized (last, GMT and system) zones, because used often and already set */
callargs[1] = NormTimezoneObj(dataPtr, timezoneObj, &loaded);
/* if loaded (setup already called for this TZ) */
if (loaded) {
return callargs[1];
}
/* before setup just take a look in TZData variable */
if (Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA], timezoneObj, 0)) {
/* put it to last slot and return normalized */
TimezoneLoaded(dataPtr, callargs[1], timezoneObj);
return callargs[1];
}
/* setup now */
callargs[0] = dataPtr->literals[LIT_SETUPTIMEZONE];
if (Tcl_EvalObjv(interp, 2, callargs, 0) == TCL_OK) {
/* save unnormalized last used */
TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, timezoneObj);
return callargs[1];
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ClockFormatNumericTimeZone --
*
* Formats a time zone as +hhmmss
*
* Parameters:
* z - Time zone in seconds east of Greenwich
*
* Results:
* Returns the time zone object (formatted in a numeric form)
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
ClockFormatNumericTimeZone(
int z)
{
char buf[12 + 1], *p;
if (z < 0) {
z = -z;
*buf = '-';
} else {
*buf = '+';
}
TclItoAw(buf + 1, z / 3600, '0', 2);
z %= 3600;
p = TclItoAw(buf + 3, z / 60, '0', 2);
z %= 60;
if (z != 0) {
p = TclItoAw(buf + 5, z, '0', 2);
}
return Tcl_NewStringObj(buf, p - buf);
}
/*
*----------------------------------------------------------------------
*
* ClockConvertlocaltoutcObjCmd --
*
* Tcl command that converts a UTC time to a local time by whatever means
* is available.
*
* Usage:
* ::tcl::clock::ConvertUTCToLocal dictionary timezone changeover
*
* Parameters:
* dict - Dictionary containing a 'localSeconds' entry.
* timezone - Time zone
* changeover - Julian Day of the adoption of the Gregorian calendar.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* On success, sets the interpreter result to the given dictionary
* augmented with a 'seconds' field giving the UTC time. On failure,
* leaves an error message in the interpreter result.
*
*----------------------------------------------------------------------
*/
static int
ClockConvertlocaltoutcObjCmd(
void *clientData, /* Literal table */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
int status;
fields.tzName = NULL;
/*
* Check params and convert time.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "dict timezone changeover");
return TCL_ERROR;
}
dict = objv[1];
if (Tcl_DictObjGet(interp, dict, dataPtr->literals[LIT_LOCALSECONDS],
&secondsObj)!= TCL_OK) {
return TCL_ERROR;
}
if (secondsObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not "
"found in dictionary", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
if ((TclGetWideIntFromObj(interp, secondsObj, &fields.localSeconds) != TCL_OK)
|| (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
|| ConvertLocalToUTC(dataPtr, interp, &fields, objv[2], changeover)) {
return TCL_ERROR;
}
/*
* Copy-on-write; set the 'seconds' field in the dictionary and place the
* modified dictionary in the interpreter result.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
status = Tcl_DictObjPut(interp, dict, dataPtr->literals[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (created) {
Tcl_DecrRefCount(dict);
}
return status;
}
/*
*----------------------------------------------------------------------
*
* ClockGetdatefieldsObjCmd --
*
* Tcl command that determines the values that [clock format] will use in
* formatting a date, and populates a dictionary with them.
*
* Usage:
* ::tcl::clock::GetDateFields seconds timezone changeover
*
* Parameters:
* seconds - Time expressed in seconds from the Posix epoch.
* timezone - Time zone in which time is to be expressed.
* changeover - Julian Day Number at which the current locale adopted
* the Gregorian calendar
*
* Results:
* Returns a dictonary populated with the fields:
* seconds - Seconds from the Posix epoch
* localSeconds - Nominal seconds from the Posix epoch in the
* local time zone.
* tzOffset - Time zone offset in seconds east of Greenwich
* tzName - Time zone name
* julianDay - Julian Day Number in the local time zone
*
*----------------------------------------------------------------------
*/
int
ClockGetdatefieldsObjCmd(
void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *dataPtr = (ClockClientData *)clientData;
Tcl_Obj *const *lit = dataPtr->literals;
int changeover;
fields.tzName = NULL;
/*
* Check params.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "seconds timezone changeover");
return TCL_ERROR;
}
if (TclGetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK
|| TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
return TCL_ERROR;
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasInternalRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
/* Extract fields */
if (ClockGetDateFields(dataPtr, interp, &fields, objv[2],
changeover) != TCL_OK) {
return TCL_ERROR;
}
/* Make dict of fields */
dict = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, dict, lit[LIT_LOCALSECONDS],
Tcl_NewWideIntObj(fields.localSeconds));
Tcl_DictObjPut(NULL, dict, lit[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
Tcl_DictObjPut(NULL, dict, lit[LIT_TZNAME], fields.tzName);
|
| ︙ | ︙ | |||
490 491 492 493 494 495 496 497 498 499 500 501 502 503 |
Tcl_NewWideIntObj(fields.iso8601Year));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601WEEK],
Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK],
Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ClockGetjuliandayfromerayearmonthdayObjCmd --
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
Tcl_NewWideIntObj(fields.iso8601Year));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601WEEK],
Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK],
Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ClockGetDateFields --
*
* Converts given UTC time (seconds in a TclDateFields structure)
* to local time and determines the values that clock routines will
* use in scanning or formatting a date.
*
* Results:
* Date-time values are stored in structure "fields".
* Returns a standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
ClockGetDateFields(
ClockClientData *dataPtr, /* Literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Pointer to result fields, where
* fields->seconds contains date to extract */
Tcl_Obj *timezoneObj, /* Time zone object or NULL for gmt */
int changeover) /* Julian Day Number */
{
/*
* Convert UTC time to local.
*/
if (ConvertUTCToLocal(dataPtr, interp, fields, timezoneObj,
changeover) != TCL_OK) {
return TCL_ERROR;
}
/*
* Extract Julian day and seconds of the day.
*/
ClockExtractJDAndSODFromSeconds(fields->julianDay, fields->secondOfDay,
fields->localSeconds);
/*
* Convert to Julian or Gregorian calendar.
*/
GetGregorianEraYearDay(fields, changeover);
GetMonthDay(fields);
GetYearWeekDay(fields, changeover);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ClockGetjuliandayfromerayearmonthdayObjCmd --
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 |
Tcl_Obj *value = NULL;
if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) {
return TCL_ERROR;
}
if (value == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | > > | 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 |
Tcl_Obj *value = NULL;
if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) {
return TCL_ERROR;
}
if (value == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"expected key(s) not found in dictionary", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
return Tcl_GetIndexFromObj(interp, value, eras, "era", TCL_EXACT, storePtr);
}
static int
FetchIntField(
Tcl_Interp *interp,
Tcl_Obj *dict,
Tcl_Obj *key,
int *storePtr)
{
Tcl_Obj *value = NULL;
if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) {
return TCL_ERROR;
}
if (value == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"expected key(s) not found in dictionary", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
return TclGetIntFromObj(interp, value, storePtr);
}
static int
ClockGetjuliandayfromerayearmonthdayObjCmd(
void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
int isBce = 0;
fields.tzName = NULL;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
|
| ︙ | ︙ | |||
640 641 642 643 644 645 646 | * result being an error message. * *---------------------------------------------------------------------- */ static int ClockGetjuliandayfromerayearweekdayObjCmd( | | > > | 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 |
* result being an error message.
*
*----------------------------------------------------------------------
*/
static int
ClockGetjuliandayfromerayearweekdayObjCmd(
void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
int isBce = 0;
fields.tzName = NULL;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
|
| ︙ | ︙ | |||
721 722 723 724 725 726 727 728 729 |
* in the interpreter result on failure.
*
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTC(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
| > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
* in the interpreter result on failure.
*
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTC(
ClockClientData *dataPtr, /* Literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *timezoneObj, /* Time zone */
int changeover) /* Julian Day of the Gregorian transition */
{
Tcl_Obj *tzdata; /* Time zone data */
Tcl_Size rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
Tcl_WideInt seconds;
ClockLastTZOffs * ltzoc = NULL;
/* fast phase-out for shared GMT-object (don't need to convert UTC 2 UTC) */
if (timezoneObj == dataPtr->literals[LIT_GMT]) {
fields->seconds = fields->localSeconds;
fields->tzOffset = 0;
return TCL_OK;
}
/*
* Check cacheable conversion could be used
* (last-period UTC2Local cache within the same TZ and seconds)
*/
for (rowc = 0; rowc < 2; rowc++) {
ltzoc = &dataPtr->lastTZOffsCache[rowc];
if (timezoneObj != ltzoc->timezoneObj || changeover != ltzoc->changeover) {
ltzoc = NULL;
continue;
}
seconds = fields->localSeconds - ltzoc->tzOffset;
if (seconds >= ltzoc->rangesVal[0]
&& seconds < ltzoc->rangesVal[1]) {
/* the same time zone and offset (UTC time inside the last minute) */
fields->tzOffset = ltzoc->tzOffset;
fields->seconds = seconds;
return TCL_OK;
}
/* in the DST-hole (because of the check above) - correct localSeconds */
if (fields->localSeconds == ltzoc->localSeconds) {
/* the same time zone and offset (but we'll shift local-time) */
fields->tzOffset = ltzoc->tzOffset;
fields->seconds = seconds;
goto dstHole;
}
}
/*
* Unpack the tz data.
*/
tzdata = ClockGetTZData(dataPtr, interp, timezoneObj);
if (tzdata == NULL) {
return TCL_ERROR;
}
if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'mktime' to convert the time to local
*/
if (rowc == 0) {
if (ConvertLocalToUTCUsingC(interp, fields, changeover) != TCL_OK) {
return TCL_ERROR;
}
/* we cannot cache (ranges unknown yet) - todo: check later the DST-hole here */
return TCL_OK;
} else {
Tcl_WideInt rangesVal[2];
if (ConvertLocalToUTCUsingTable(interp, fields, rowc, rowv,
rangesVal) != TCL_OK) {
return TCL_ERROR;
}
seconds = fields->seconds;
/* Cache the last conversion */
if (ltzoc != NULL) { /* slot was found above */
/* timezoneObj and changeover are the same */
TclSetObjRef(ltzoc->tzName, fields->tzName); /* may be NULL */
} else {
/* no TZ in cache - just move second slot down and use the first one */
ltzoc = &dataPtr->lastTZOffsCache[0];
TclUnsetObjRef(dataPtr->lastTZOffsCache[1].timezoneObj);
TclUnsetObjRef(dataPtr->lastTZOffsCache[1].tzName);
memcpy(&dataPtr->lastTZOffsCache[1], ltzoc, sizeof(*ltzoc));
TclInitObjRef(ltzoc->timezoneObj, timezoneObj);
ltzoc->changeover = changeover;
TclInitObjRef(ltzoc->tzName, fields->tzName); /* may be NULL */
}
ltzoc->localSeconds = fields->localSeconds;
ltzoc->rangesVal[0] = rangesVal[0];
ltzoc->rangesVal[1] = rangesVal[1];
ltzoc->tzOffset = fields->tzOffset;
}
/* check DST-hole: if retrieved seconds is out of range */
if (ltzoc->rangesVal[0] > seconds || seconds >= ltzoc->rangesVal[1]) {
dstHole:
#if 0
printf("given local-time is outside the time-zone (in DST-hole): "
"%" TCL_LL_MODIFIER "d - offs %d => %" TCL_LL_MODIFIER "d <= %" TCL_LL_MODIFIER "d < %" TCL_LL_MODIFIER "d\n",
fields->localSeconds, fields->tzOffset,
ltzoc->rangesVal[0], seconds, ltzoc->rangesVal[1]);
#endif
/* because we don't know real TZ (we're outsize), just invalidate local
* time (which could be verified in ClockValidDate later) */
fields->localSeconds = TCL_INV_SECONDS; /* not valid seconds */
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ConvertLocalToUTCUsingTable --
*
|
| ︙ | ︙ | |||
771 772 773 774 775 776 777 |
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTCUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
| | | > > > > | | < < | | > | < | | | < < | | | > | < > > | > > | 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 |
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTCUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int rowc, /* Number of points at which time changes */
Tcl_Obj *const rowv[], /* Points at which time changes */
Tcl_WideInt *rangesVal) /* Return bounds for time period */
{
Tcl_Obj *row;
Tcl_Size cellc;
Tcl_Obj **cellv;
struct {
Tcl_Obj *tzName;
int tzOffset;
} have[8];
int nHave = 0;
Tcl_Size i;
/*
* Perform an initial lookup assuming that local == UTC, and locate the
* last time conversion prior to that time. Get the offset from that row,
* and look up again. Continue until we find an offset that we found
* before. This definition, rather than "the same offset" ensures that we
* don't enter an endless loop, as would otherwise happen when trying to
* convert a non-existent time such as 02:30 during the US Spring Daylight
* Saving Time transition.
*/
fields->tzOffset = 0;
fields->seconds = fields->localSeconds;
while (1) {
row = LookupLastTransition(interp, fields->seconds, rowc, rowv,
rangesVal);
if ((row == NULL)
|| TclListObjGetElements(interp, row, &cellc,
&cellv) != TCL_OK
|| TclGetIntFromObj(interp, cellv[1],
&fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < nHave; ++i) {
if (have[i].tzOffset == fields->tzOffset) {
goto found;
}
}
if (nHave == 8) {
Tcl_Panic("loop in ConvertLocalToUTCUsingTable");
}
have[nHave].tzName = cellv[3];
have[nHave++].tzOffset = fields->tzOffset;
fields->seconds = fields->localSeconds - fields->tzOffset;
}
found:
fields->tzOffset = have[i].tzOffset;
fields->seconds = fields->localSeconds - fields->tzOffset;
TclSetObjRef(fields->tzName, have[i].tzName);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ConvertLocalToUTCUsingC --
|
| ︙ | ︙ | |||
851 852 853 854 855 856 857 |
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
struct tm timeVal;
int localErrno;
int secondOfDay;
| < < | < < < | | | 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 |
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
struct tm timeVal;
int localErrno;
int secondOfDay;
/*
* Convert the given time to a date.
*/
ClockExtractJDAndSODFromSeconds(fields->julianDay, secondOfDay,
fields->localSeconds);
GetGregorianEraYearDay(fields, changeover);
GetMonthDay(fields);
/*
* Convert the date/time to a 'struct tm'.
*/
|
| ︙ | ︙ | |||
900 901 902 903 904 905 906 |
/*
* If conversion fails, report an error.
*/
if (localErrno != 0
|| (fields->seconds == -1 && timeVal.tm_yday == -1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 |
/*
* If conversion fails, report an error.
*/
if (localErrno != 0
|| (fields->seconds == -1 && timeVal.tm_yday == -1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"time value too large/small to represent", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 | * * Side effects: * Populates the 'tzName' and 'tzOffset' fields. * *---------------------------------------------------------------------- */ | | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*
* Side effects:
* Populates the 'tzName' and 'tzOffset' fields.
*
*----------------------------------------------------------------------
*/
int
ConvertUTCToLocal(
ClockClientData *dataPtr, /* Literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *timezoneObj, /* Time zone */
int changeover) /* Julian Day of the Gregorian transition */
{
Tcl_Obj *tzdata; /* Time zone data */
Tcl_Size rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
ClockLastTZOffs * ltzoc = NULL;
/* fast phase-out for shared GMT-object (don't need to convert UTC 2 UTC) */
if (timezoneObj == dataPtr->literals[LIT_GMT]) {
fields->localSeconds = fields->seconds;
fields->tzOffset = 0;
if (dataPtr->gmtTZName == NULL) {
Tcl_Obj *tzName;
tzdata = ClockGetTZData(dataPtr, interp, timezoneObj);
if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK
|| Tcl_ListObjIndex(interp, rowv[0], 3, &tzName) != TCL_OK) {
return TCL_ERROR;
}
TclSetObjRef(dataPtr->gmtTZName, tzName);
}
TclSetObjRef(fields->tzName, dataPtr->gmtTZName);
return TCL_OK;
}
/*
* Check cacheable conversion could be used
* (last-period UTC2Local cache within the same TZ and seconds)
*/
for (rowc = 0; rowc < 2; rowc++) {
ltzoc = &dataPtr->lastTZOffsCache[rowc];
if (timezoneObj != ltzoc->timezoneObj || changeover != ltzoc->changeover) {
ltzoc = NULL;
continue;
}
if (fields->seconds >= ltzoc->rangesVal[0]
&& fields->seconds < ltzoc->rangesVal[1]) {
/* the same time zone and offset (UTC time inside the last minute) */
fields->tzOffset = ltzoc->tzOffset;
fields->localSeconds = fields->seconds + fields->tzOffset;
TclSetObjRef(fields->tzName, ltzoc->tzName);
return TCL_OK;
}
}
/*
* Unpack the tz data.
*/
tzdata = ClockGetTZData(dataPtr, interp, timezoneObj);
if (tzdata == NULL) {
return TCL_ERROR;
}
if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'localtime' to convert the time to local
*/
if (rowc == 0) {
if (ConvertUTCToLocalUsingC(interp, fields, changeover) != TCL_OK) {
return TCL_ERROR;
}
/* signal we need to revalidate TZ epoch next time fields gets used. */
fields->flags |= CLF_CTZ;
/* we cannot cache (ranges unknown yet) */
} else {
Tcl_WideInt rangesVal[2];
if (ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv,
rangesVal) != TCL_OK) {
return TCL_ERROR;
}
/* converted using table (TZ isn't :localtime) */
fields->flags &= ~CLF_CTZ;
/* Cache the last conversion */
if (ltzoc != NULL) { /* slot was found above */
/* timezoneObj and changeover are the same */
TclSetObjRef(ltzoc->tzName, fields->tzName);
} else {
/* no TZ in cache - just move second slot down and use the first one */
ltzoc = &dataPtr->lastTZOffsCache[0];
TclUnsetObjRef(dataPtr->lastTZOffsCache[1].timezoneObj);
TclUnsetObjRef(dataPtr->lastTZOffsCache[1].tzName);
memcpy(&dataPtr->lastTZOffsCache[1], ltzoc, sizeof(*ltzoc));
TclInitObjRef(ltzoc->timezoneObj, timezoneObj);
ltzoc->changeover = changeover;
TclInitObjRef(ltzoc->tzName, fields->tzName);
}
ltzoc->localSeconds = fields->localSeconds;
ltzoc->rangesVal[0] = rangesVal[0];
ltzoc->rangesVal[1] = rangesVal[1];
ltzoc->tzOffset = fields->tzOffset;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ConvertUTCToLocalUsingTable --
*
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 |
*----------------------------------------------------------------------
*/
static int
ConvertUTCToLocalUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the date */
| | | > | | | | | | < | 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 |
*----------------------------------------------------------------------
*/
static int
ConvertUTCToLocalUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the date */
Tcl_Size rowc, /* Number of rows in the conversion table
* (>= 1) */
Tcl_Obj *const rowv[], /* Rows of the conversion table */
Tcl_WideInt *rangesVal) /* Return bounds for time period */
{
Tcl_Obj *row; /* Row containing the current information */
Tcl_Size cellc; /* Count of cells in the row (must be 4) */
Tcl_Obj **cellv; /* Pointers to the cells */
/*
* Look up the nearest transition time.
*/
row = LookupLastTransition(interp, fields->seconds, rowc, rowv, rangesVal);
if (row == NULL
|| TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK
|| TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
/*
* Convert the time.
*/
TclSetObjRef(fields->tzName, cellv[3]);
fields->localSeconds = fields->seconds + fields->tzOffset;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 |
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
time_t tock;
struct tm *timeVal; /* Time after conversion */
int diff; /* Time zone diff local-Greenwich */
| | | | | | | | | | | | < | | | > | < | | > > > > | | > | > > > > > > | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 |
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
time_t tock;
struct tm *timeVal; /* Time after conversion */
int diff; /* Time zone diff local-Greenwich */
char buffer[16], *p; /* Buffer for time zone name */
/*
* Use 'localtime' to determine local year, month, day, time of day.
*/
tock = (time_t) fields->seconds;
if ((Tcl_WideInt) tock != fields->seconds) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number too large to represent as a Posix time", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", (char *)NULL);
return TCL_ERROR;
}
TzsetIfNecessary();
timeVal = ThreadSafeLocalTime(&tock);
if (timeVal == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"localtime failed (clock value may be too "
"large/small to represent)", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char *)NULL);
return TCL_ERROR;
}
/*
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
fields->isBce = 0;
fields->year = timeVal->tm_year + 1900;
fields->month = timeVal->tm_mon + 1;
fields->dayOfMonth = timeVal->tm_mday;
GetJulianDayFromEraYearMonthDay(fields, changeover);
/*
* Convert that value to seconds.
*/
fields->localSeconds = (((fields->julianDay * 24LL
+ timeVal->tm_hour) * 60 + timeVal->tm_min) * 60
+ timeVal->tm_sec) - JULIAN_SEC_POSIX_EPOCH;
/*
* Determine a time zone offset and name; just use +hhmm for the name.
*/
diff = (int) (fields->localSeconds - fields->seconds);
fields->tzOffset = diff;
if (diff < 0) {
*buffer = '-';
diff = -diff;
} else {
*buffer = '+';
}
TclItoAw(buffer + 1, diff / 3600, '0', 2);
diff %= 3600;
p = TclItoAw(buffer + 3, diff / 60, '0', 2);
diff %= 60;
if (diff != 0) {
p = TclItoAw(buffer + 5, diff, '0', 2);
}
TclSetObjRef(fields->tzName, Tcl_NewStringObj(buffer, p - buffer));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* LookupLastTransition --
*
* Given a UTC time and a tzdata array, looks up the last transition on
* or before the given time.
*
* Results:
* Returns a pointer to the row, or NULL if an error occurs.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
LookupLastTransition(
Tcl_Interp *interp, /* Interpreter for error messages */
Tcl_WideInt tick, /* Time from the epoch */
Tcl_Size rowc, /* Number of rows of tzdata */
Tcl_Obj *const *rowv, /* Rows in tzdata */
Tcl_WideInt *rangesVal) /* Return bounds for time period */
{
Tcl_Size l, u;
Tcl_Obj *compObj;
Tcl_WideInt compVal, fromVal = LLONG_MIN, toVal = LLONG_MAX;
/*
* Examine the first row to make sure we're in bounds.
*/
if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK
|| TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
return NULL;
}
/*
* Bizarre case - first row doesn't begin at MIN_WIDE_INT. Return it
* anyway.
*/
if (tick < (fromVal = compVal)) {
if (rangesVal) {
rangesVal[0] = fromVal;
rangesVal[1] = toVal;
}
return rowv[0];
}
/*
* Binary-search to find the transition.
*/
l = 0;
u = rowc - 1;
while (l < u) {
Tcl_Size m = (l + u + 1) / 2;
if (Tcl_ListObjIndex(interp, rowv[m], 0, &compObj) != TCL_OK ||
TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
return NULL;
}
if (tick >= compVal) {
l = m;
fromVal = compVal;
} else {
u = m - 1;
toVal = compVal;
}
}
if (rangesVal) {
rangesVal[0] = fromVal;
rangesVal[1] = toVal;
}
return rowv[l];
}
/*
*----------------------------------------------------------------------
*
* GetYearWeekDay --
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 |
GetYearWeekDay(
TclDateFields *fields, /* Date to convert, must have 'julianDay' */
int changeover) /* Julian Day Number of the Gregorian
* transition */
{
TclDateFields temp;
int dayOfFiscalYear;
/*
* Find the given date, minus three days, plus one year. That date's
* iso8601 year is an upper bound on the ISO8601 year of the given date.
*/
temp.julianDay = fields->julianDay - 3;
| > > | 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 |
GetYearWeekDay(
TclDateFields *fields, /* Date to convert, must have 'julianDay' */
int changeover) /* Julian Day Number of the Gregorian
* transition */
{
TclDateFields temp;
int dayOfFiscalYear;
temp.tzName = NULL;
/*
* Find the given date, minus three days, plus one year. That date's
* iso8601 year is an upper bound on the ISO8601 year of the given date.
*/
temp.julianDay = fields->julianDay - 3;
|
| ︙ | ︙ | |||
1224 1225 1226 1227 1228 1229 1230 |
GetJulianDayFromEraYearWeekDay(&temp, changeover);
}
fields->iso8601Year = temp.iso8601Year;
dayOfFiscalYear = fields->julianDay - temp.julianDay;
fields->iso8601Week = (dayOfFiscalYear / 7) + 1;
fields->dayOfWeek = (dayOfFiscalYear + 1) % 7;
| | | 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 |
GetJulianDayFromEraYearWeekDay(&temp, changeover);
}
fields->iso8601Year = temp.iso8601Year;
dayOfFiscalYear = fields->julianDay - temp.julianDay;
fields->iso8601Week = (dayOfFiscalYear / 7) + 1;
fields->dayOfWeek = (dayOfFiscalYear + 1) % 7;
if (fields->dayOfWeek < 1) { /* Mon .. Sun == 1 .. 7 */
fields->dayOfWeek += 7;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 |
*/
static void
GetGregorianEraYearDay(
TclDateFields *fields, /* Date fields containing 'julianDay' */
int changeover) /* Gregorian transition date */
{
| | | | | | 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 |
*/
static void
GetGregorianEraYearDay(
TclDateFields *fields, /* Date fields containing 'julianDay' */
int changeover) /* Gregorian transition date */
{
Tcl_WideInt jday = fields->julianDay;
Tcl_WideInt day;
Tcl_WideInt year;
Tcl_WideInt n;
if (jday >= changeover) {
/*
* Gregorian calendar.
*/
fields->gregorian = 1;
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 |
static void
GetMonthDay(
TclDateFields *fields) /* Date to convert */
{
int day = fields->dayOfYear;
int month;
| | > > > > > > > > > > > > | > > | | > > | | | > > | 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 |
static void
GetMonthDay(
TclDateFields *fields) /* Date to convert */
{
int day = fields->dayOfYear;
int month;
const int *dipm = daysInPriorMonths[IsGregorianLeapYear(fields)];
/*
* Estimate month by calculating `dayOfYear / (365/12)`
*/
month = (day*12) / dipm[12];
/* then do forwards backwards correction */
while (1) {
if (day > dipm[month]) {
if (month >= 11 || day <= dipm[month + 1]) {
break;
}
month++;
} else {
if (month == 0) {
break;
}
month--;
}
}
day -= dipm[month];
fields->month = month + 1;
fields->dayOfMonth = day;
}
/*
*----------------------------------------------------------------------
*
* GetJulianDayFromEraYearWeekDay --
*
* Given a TclDateFields structure containing era, ISO8601 year, ISO8601
* week, and day of week, computes the Julian Day Number.
*
* Results:
* None.
*
* Side effects:
* Stores 'julianDay' in the fields.
*
*----------------------------------------------------------------------
*/
void
GetJulianDayFromEraYearWeekDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Julian Day Number of the Gregorian
* transition */
{
Tcl_WideInt firstMonday; /* Julian day number of week 1, day 1 in the
* given year */
TclDateFields firstWeek;
firstWeek.tzName = NULL;
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
firstWeek.isBce = fields->isBce;
firstWeek.year = fields->iso8601Year;
|
| ︙ | ︙ | |||
1446 1447 1448 1449 1450 1451 1452 | * * Side effects: * Stores day number in 'julianDay' * *---------------------------------------------------------------------- */ | | > | | 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 |
*
* Side effects:
* Stores day number in 'julianDay'
*
*----------------------------------------------------------------------
*/
void
GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
Tcl_WideInt year, ym1, ym1o4, ym1o100, ym1o400;
int month, mm1, q, r;
if (fields->isBce) {
year = 1 - fields->year;
} else {
year = fields->year;
}
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
/*
* Adjust the year after reducing the month.
*/
fields->gregorian = 1;
if (year < 1) {
fields->isBce = 1;
| | | 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 |
/*
* Adjust the year after reducing the month.
*/
fields->gregorian = 1;
if (year < 1) {
fields->isBce = 1;
fields->year = 1 - year;
} else {
fields->isBce = 0;
fields->year = year;
}
/*
* Try an initial conversion in the Gregorian calendar.
|
| ︙ | ︙ | |||
1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 |
+ ym1o4;
}
}
/*
*----------------------------------------------------------------------
*
* IsGregorianLeapYear --
*
* Tests whether a given year is a leap year, in either Julian or
* Gregorian calendar.
*
* Results:
* Returns 1 for a leap year, 0 otherwise.
*
*----------------------------------------------------------------------
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 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 |
+ ym1o4;
}
}
/*
*----------------------------------------------------------------------
*
* GetJulianDayFromEraYearDay --
*
* Given era, year, and dayOfYear (in TclDateFields), and the
* Gregorian transition date, computes the Julian Day Number.
*
* Results:
* None.
*
* Side effects:
* Stores day number in 'julianDay'
*
*----------------------------------------------------------------------
*/
void
GetJulianDayFromEraYearDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
Tcl_WideInt year, ym1;
/* Get absolute year number from the civil year */
if (fields->isBce) {
year = 1 - fields->year;
} else {
year = fields->year;
}
ym1 = year - 1;
/* Try the Gregorian calendar first. */
fields->gregorian = 1;
fields->julianDay =
1721425
+ fields->dayOfYear
+ (365 * ym1)
+ (ym1 / 4)
- (ym1 / 100)
+ (ym1 / 400);
/* If the date is before the Gregorian change, use the Julian calendar. */
if (fields->julianDay < changeover) {
fields->gregorian = 0;
fields->julianDay =
1721423
+ fields->dayOfYear
+ (365 * ym1)
+ (ym1 / 4);
}
}
/*
*----------------------------------------------------------------------
*
* IsGregorianLeapYear --
*
* Tests whether a given year is a leap year, in either Julian or
* Gregorian calendar.
*
* Results:
* Returns 1 for a leap year, 0 otherwise.
*
*----------------------------------------------------------------------
*/
int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
Tcl_WideInt year = fields->year;
if (fields->isBce) {
year = 1 - year;
}
if (year % 4 != 0) {
return 0;
} else if (!(fields->gregorian)) {
return 1;
} else if (year % 400 == 0) {
return 1;
} else if (year % 100 == 0) {
return 0;
} else {
return 1;
}
}
/*
*----------------------------------------------------------------------
*
* WeekdayOnOrBefore --
*
* Finds the Julian Day Number of a given day of the week that falls on
* or before a given date, expressed as Julian Day Number.
*
* Results:
* Returns the Julian Day Number
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
WeekdayOnOrBefore(
int dayOfWeek, /* Day of week; Sunday == 0 or 7 */
Tcl_WideInt julianDay) /* Reference date */
{
int k = (dayOfWeek + 6) % 7;
if (k < 0) {
k += 7;
}
return julianDay - ((julianDay - k) % 7);
}
|
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 |
Tcl_WCharToUtfDString(varValue, -1, &ds);
Tcl_DStringResult(interp, &ds);
}
#else
varName = TclGetString(objv[1]);
varValue = getenv(varName);
if (varValue != NULL) {
| | > | 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 |
Tcl_WCharToUtfDString(varValue, -1, &ds);
Tcl_DStringResult(interp, &ds);
}
#else
varName = TclGetString(objv[1]);
varValue = getenv(varName);
if (varValue != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
varValue, TCL_AUTO_LENGTH));
}
#endif
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 |
case 2:
if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
break;
default:
| | | | 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 |
case 2:
if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
break;
default:
Tcl_WrongNumArgs(interp, 0, objv, "clock clicks ?-switch?");
return TCL_ERROR;
}
switch (index) {
case CLICKS_MILLIS:
Tcl_GetTime(&now);
clicks = now.sec * 1000LL + now.usec / 1000;
break;
case CLICKS_NATIVE:
#ifdef TCL_WIDE_CLICKS
clicks = TclpGetWideClicks();
#else
clicks = (Tcl_WideInt)TclpGetClicks();
#endif
|
| ︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 |
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
| | | 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 |
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 0, objv, "clock milliseconds");
return TCL_ERROR;
}
Tcl_GetTime(&now);
TclNewUIntObj(timeObj, (Tcl_WideUInt)
now.sec * 1000 + now.usec / 1000);
Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
|
| ︙ | ︙ | |||
1842 1843 1844 1845 1846 1847 1848 |
ClockMicrosecondsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
| | > > > > > > > > > > > | | > > > > | | < < < < > > > > > > | < | > > | | > > > | < < < < < | | | | | > | < > | < < | > | | < < < | < < < > > > > > > > > > | | | > > > > > > > > | < > | > > > | | | | | | | > > > > > > > > > > > > > > > > > > > < < < | | | > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | > | > | > | > > > > > > > | 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 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 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 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 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 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 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 |
ClockMicrosecondsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 0, objv, "clock microseconds");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
return TCL_OK;
}
static inline void
ClockInitFmtScnArgs(
ClockClientData *dataPtr,
Tcl_Interp *interp,
ClockFmtScnCmdArgs *opts)
{
memset(opts, 0, sizeof(*opts));
opts->dataPtr = dataPtr;
opts->interp = interp;
}
/*
*-----------------------------------------------------------------------------
*
* ClockParseFmtScnArgs --
*
* Parses the arguments for sub-commands "scan", "format" and "add".
*
* Note: common options table used here, because for the options often used
* the same literals (objects), so it avoids permanent "recompiling" of
* option object representation to indexType with another table.
*
* Results:
* Returns a standard Tcl result, and stores parsed options
* (format, the locale, timezone and base) in structure "opts".
*
*-----------------------------------------------------------------------------
*/
typedef enum ClockOperation {
CLC_OP_FMT = 0, /* Doing [clock format] */
CLC_OP_SCN, /* Doing [clock scan] */
CLC_OP_ADD /* Doing [clock add] */
} ClockOperation;
static int
ClockParseFmtScnArgs(
ClockFmtScnCmdArgs *opts, /* Result vector: format, locale, timezone... */
TclDateFields *date, /* Extracted date-time corresponding base
* (by scan or add) resp. clockval (by format) */
Tcl_Size objc, /* Parameter count */
Tcl_Obj *const objv[], /* Parameter vector */
ClockOperation operation, /* What operation are we doing: format, scan, add */
const char *syntax) /* Syntax of the current command */
{
Tcl_Interp *interp = opts->interp;
ClockClientData *dataPtr = opts->dataPtr;
int gmtFlag = 0;
static const char *const options[] = {
"-base", "-format", "-gmt", "-locale", "-timezone", "-validate", NULL
};
enum optionInd {
CLC_ARGS_BASE, CLC_ARGS_FORMAT, CLC_ARGS_GMT, CLC_ARGS_LOCALE,
CLC_ARGS_TIMEZONE, CLC_ARGS_VALIDATE
};
int optionIndex; /* Index of an option. */
int saw = 0; /* Flag == 1 if option was seen already. */
Tcl_Size i, baseIdx;
Tcl_WideInt baseVal; /* Base time, expressed in seconds from the Epoch */
if (operation == CLC_OP_SCN) {
/* default flags (from configure) */
opts->flags |= dataPtr->defFlags & CLF_VALIDATE;
} else {
/* clock value (as current base) */
opts->baseObj = objv[(baseIdx = 1)];
saw |= 1 << CLC_ARGS_BASE;
}
/*
* Extract values for the keywords.
*/
for (i = 2; i < objc; i+=2) {
/* bypass integers (offsets) by "clock add" */
if (operation == CLC_OP_ADD) {
Tcl_WideInt num;
if (TclGetWideIntFromObj(NULL, objv[i], &num) == TCL_OK) {
continue;
}
}
/* get option */
if (Tcl_GetIndexFromObj(interp, objv[i], options,
"option", 0, &optionIndex) != TCL_OK) {
goto badOptionMsg;
}
/* if already specified */
if (saw & (1 << optionIndex)) {
if (operation != CLC_OP_SCN && optionIndex == CLC_ARGS_BASE) {
goto badOptionMsg;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": doubly present",
TclGetString(objv[i])));
goto badOption;
}
switch (optionIndex) {
case CLC_ARGS_FORMAT:
if (operation == CLC_OP_ADD) {
goto badOptionMsg;
}
opts->formatObj = objv[i + 1];
break;
case CLC_ARGS_GMT:
if (Tcl_GetBooleanFromObj(interp, objv[i + 1], &gmtFlag) != TCL_OK){
return TCL_ERROR;
}
break;
case CLC_ARGS_LOCALE:
opts->localeObj = objv[i + 1];
break;
case CLC_ARGS_TIMEZONE:
opts->timezoneObj = objv[i + 1];
break;
case CLC_ARGS_BASE:
opts->baseObj = objv[(baseIdx = i + 1)];
break;
case CLC_ARGS_VALIDATE:
if (operation != CLC_OP_SCN) {
goto badOptionMsg;
} else {
int val;
if (Tcl_GetBooleanFromObj(interp, objv[i + 1], &val) != TCL_OK) {
return TCL_ERROR;
}
if (val) {
opts->flags |= CLF_VALIDATE;
} else {
opts->flags &= ~CLF_VALIDATE;
}
}
break;
}
saw |= 1 << optionIndex;
}
/*
* Check options.
*/
if ((saw & (1 << CLC_ARGS_GMT))
&& (saw & (1 << CLC_ARGS_TIMEZONE))) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use -gmt and -timezone in same call", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", (char *)NULL);
return TCL_ERROR;
}
if (gmtFlag) {
opts->timezoneObj = dataPtr->literals[LIT_GMT];
} else if (opts->timezoneObj == NULL
|| TclGetString(opts->timezoneObj) == NULL
|| opts->timezoneObj->length == 0) {
/* If time zone not specified use system time zone */
opts->timezoneObj = ClockGetSystemTimeZone(dataPtr, interp);
if (opts->timezoneObj == NULL) {
return TCL_ERROR;
}
}
/* Setup timezone (normalize object if needed and load TZ on demand) */
opts->timezoneObj = ClockSetupTimeZone(dataPtr, interp, opts->timezoneObj);
if (opts->timezoneObj == NULL) {
return TCL_ERROR;
}
/* Base (by scan or add) or clock value (by format) */
if (opts->baseObj != NULL) {
Tcl_Obj *baseObj = opts->baseObj;
/* bypass integer recognition if looks like "now" or "-now" */
if ((baseObj->bytes &&
((baseObj->length == 3 && baseObj->bytes[0] == 'n') ||
(baseObj->length == 4 && baseObj->bytes[1] == 'n')))
|| TclGetWideIntFromObj(NULL, baseObj, &baseVal) != TCL_OK) {
/* we accept "now" and "-now" as current date-time */
static const char *const nowOpts[] = {
"now", "-now", NULL
};
int idx;
if (Tcl_GetIndexFromObj(NULL, baseObj, nowOpts, "seconds",
TCL_EXACT, &idx) == TCL_OK) {
goto baseNow;
}
if (TclHasInternalRep(baseObj, &tclBignumType)) {
goto baseOverflow;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad seconds \"%s\": must be now or integer",
TclGetString(baseObj)));
i = baseIdx;
goto badOption;
}
/*
* Seconds could be an unsigned number that overflowed. Make sure
* that it isn't. Additionally it may be too complex to calculate
* julianday etc (forwards/backwards) by too large/small values, thus
* just let accept a bit shorter values to avoid overflow.
* Note the year is currently an integer, thus avoid to overflow it also.
*/
if (TclHasInternalRep(baseObj, &tclBignumType)
|| baseVal < TCL_MIN_SECONDS || baseVal > TCL_MAX_SECONDS) {
baseOverflow:
Tcl_SetObjResult(interp, dataPtr->literals[LIT_INTEGER_VALUE_TOO_LARGE]);
i = baseIdx;
goto badOption;
}
} else {
Tcl_Time now;
baseNow:
Tcl_GetTime(&now);
baseVal = (Tcl_WideInt) now.sec;
}
/*
* Extract year, month and day from the base time for the parser to use as
* defaults
*/
/* check base fields already cached (by TZ, last-second cache) */
if (dataPtr->lastBase.timezoneObj == opts->timezoneObj
&& dataPtr->lastBase.date.seconds == baseVal
&& (!(dataPtr->lastBase.date.flags & CLF_CTZ)
|| dataPtr->lastTZEpoch == TzsetIfNecessary())) {
memcpy(date, &dataPtr->lastBase.date, ClockCacheableDateFieldsSize);
} else {
/* extact fields from base */
date->seconds = baseVal;
if (ClockGetDateFields(dataPtr, interp, date, opts->timezoneObj,
GREGORIAN_CHANGE_DATE) != TCL_OK) {
/* TODO - GREGORIAN_CHANGE_DATE should be locale-dependent */
return TCL_ERROR;
}
/* cache last base */
memcpy(&dataPtr->lastBase.date, date, ClockCacheableDateFieldsSize);
TclSetObjRef(dataPtr->lastBase.timezoneObj, opts->timezoneObj);
}
return TCL_OK;
badOptionMsg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be %s",
TclGetString(objv[i]), syntax));
badOption:
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
(i < objc) ? TclGetString(objv[i]) : (char *)NULL, (char *)NULL);
return TCL_ERROR;
}
/*----------------------------------------------------------------------
*
* ClockFormatObjCmd -- , clock format --
*
* This function is invoked to process the Tcl "clock format" command.
*
* Formats a count of seconds since the Posix Epoch as a time of day.
*
* The 'clock format' command formats times of day for output. Refer
* to the user documentation to see what it does.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
ClockFormatObjCmd(
void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter values */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
static const char *syntax = "clock format clockval|now "
"?-format string? "
"?-gmt boolean? "
"?-locale LOCALE? ?-timezone ZONE?";
int ret;
ClockFmtScnCmdArgs opts; /* Format, locale, timezone and base */
DateFormat dateFmt; /* Common structure used for formatting */
/* even number of arguments */
if ((objc & 1) == 1) {
Tcl_WrongNumArgs(interp, 0, objv, syntax);
Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL);
return TCL_ERROR;
}
memset(&dateFmt, 0, sizeof(dateFmt));
/*
* Extract values for the keywords.
*/
ClockInitFmtScnArgs(dataPtr, interp, &opts);
ret = ClockParseFmtScnArgs(&opts, &dateFmt.date, objc, objv,
CLC_OP_FMT, "-format, -gmt, -locale, or -timezone");
if (ret != TCL_OK) {
goto done;
}
/* Default format */
if (opts.formatObj == NULL) {
opts.formatObj = dataPtr->literals[LIT__DEFAULT_FORMAT];
}
/* Use compiled version of Format - */
ret = ClockFormat(&dateFmt, &opts);
done:
TclUnsetObjRef(dateFmt.date.tzName);
return ret;
}
/*----------------------------------------------------------------------
*
* ClockScanObjCmd -- , clock scan --
*
* This function is invoked to process the Tcl "clock scan" command.
*
* Inputs a count of seconds since the Posix Epoch as a time of day.
*
* The 'clock scan' command scans times of day on input. Refer to the
* user documentation to see what it does.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
ClockScanObjCmd(
void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter values */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
static const char *syntax = "clock scan string "
"?-base seconds? "
"?-format string? "
"?-gmt boolean? "
"?-locale LOCALE? ?-timezone ZONE? ?-validate boolean?";
int ret;
ClockFmtScnCmdArgs opts; /* Format, locale, timezone and base */
DateInfo yy; /* Common structure used for parsing */
DateInfo *info = &yy;
/* even number of arguments */
if ((objc & 1) == 1) {
Tcl_WrongNumArgs(interp, 0, objv, syntax);
Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL);
return TCL_ERROR;
}
ClockInitDateInfo(&yy);
/*
* Extract values for the keywords.
*/
ClockInitFmtScnArgs(dataPtr, interp, &opts);
ret = ClockParseFmtScnArgs(&opts, &yy.date, objc, objv,
CLC_OP_SCN, "-base, -format, -gmt, -locale, -timezone or -validate");
if (ret != TCL_OK) {
goto done;
}
/* seconds are in localSeconds (relative base date), so reset time here */
yyHour = yyMinutes = yySeconds = yySecondOfDay = 0; yyMeridian = MER24;
/* If free scan */
if (opts.formatObj == NULL) {
/* Use compiled version of FreeScan - */
/* [SB] TODO: Perhaps someday we'll localize the legacy code. Right now,
* it's not localized. */
if (opts.localeObj != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"legacy [clock scan] does not support -locale", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "CLOCK", "flagWithLegacyFormat", (char *)NULL);
ret = TCL_ERROR;
goto done;
}
ret = ClockFreeScan(&yy, objv[1], &opts);
} else {
/* Use compiled version of Scan - */
ret = ClockScan(&yy, objv[1], &opts);
}
if (ret != TCL_OK) {
goto done;
}
/*
* If no GMT and not free-scan (where valid stage 1 is done in-between),
* validate with stage 1 before local time conversion, otherwise it may
* adjust date/time tokens to valid values
*/
if ((opts.flags & CLF_VALIDATE_S1)
&& info->flags & (CLF_ASSEMBLE_SECONDS|CLF_LOCALSEC)) {
ret = ClockValidDate(&yy, &opts, CLF_VALIDATE_S1);
if (ret != TCL_OK) {
goto done;
}
}
/* Convert date info structure into UTC seconds */
ret = ClockScanCommit(&yy, &opts);
if (ret != TCL_OK) {
goto done;
}
/* Apply remaining validation rules, if expected */
if (opts.flags & CLF_VALIDATE) {
ret = ClockValidDate(&yy, &opts, opts.flags & CLF_VALIDATE);
if (ret != TCL_OK) {
goto done;
}
}
done:
TclUnsetObjRef(yy.date.tzName);
if (ret != TCL_OK) {
return ret;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(yy.date.seconds));
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* ClockScanCommit --
*
* Converts date info structure into UTC seconds.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ClockScanCommit(
DateInfo *info, /* Clock scan info structure */
ClockFmtScnCmdArgs *opts) /* Format, locale, timezone and base */
{
/* If needed assemble julianDay using year, month, etc. */
if (info->flags & CLF_ASSEMBLE_JULIANDAY) {
if (info->flags & CLF_ISO8601WEEK) {
GetJulianDayFromEraYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE);
} else if (!(info->flags & CLF_DAYOFYEAR) /* no day of year */
|| (info->flags & (CLF_DAYOFMONTH|CLF_MONTH)) /* yymmdd over yyddd */
== (CLF_DAYOFMONTH|CLF_MONTH)) {
GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE);
} else {
GetJulianDayFromEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
}
info->flags |= CLF_ASSEMBLE_SECONDS;
info->flags &= ~CLF_ASSEMBLE_JULIANDAY;
}
/* some overflow checks */
if (info->flags & CLF_JULIANDAY) {
double curJDN = (double)yydate.julianDay
+ ((double)yySecondOfDay - SECONDS_PER_DAY/2) / SECONDS_PER_DAY;
if (curJDN > opts->dataPtr->maxJDN) {
Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
"requested date too large to represent", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(opts->interp, "CLOCK", "dateTooLarge", (char *)NULL);
return TCL_ERROR;
}
}
/* If seconds overflows the day (not valide case, or 24:00), increase days */
if (yySecondOfDay >= SECONDS_PER_DAY) {
yydate.julianDay += (yySecondOfDay / SECONDS_PER_DAY);
yySecondOfDay %= SECONDS_PER_DAY;
}
/* Local seconds to UTC (stored in yydate.seconds) */
if (info->flags & CLF_ASSEMBLE_SECONDS) {
yydate.localSeconds =
-210866803200LL
+ (SECONDS_PER_DAY * yydate.julianDay)
+ yySecondOfDay;
}
if (info->flags & (CLF_ASSEMBLE_SECONDS | CLF_LOCALSEC)) {
if (ConvertLocalToUTC(opts->dataPtr, opts->interp, &yydate,
opts->timezoneObj, GREGORIAN_CHANGE_DATE) != TCL_OK) {
return TCL_ERROR;
}
}
/* Increment UTC seconds with relative time */
yydate.seconds += yyRelSeconds;
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* ClockValidDate --
*
* Validate date info structure for wrong data (e. g. out of ranges).
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ClockValidDate(
DateInfo *info, /* Clock scan info structure */
ClockFmtScnCmdArgs *opts, /* Scan options */
int stage) /* Stage to validate (1, 2 or 3 for both) */
{
const char *errMsg = "", *errCode = "";
TclDateFields temp;
int tempCpyFlg = 0;
ClockClientData *dataPtr = opts->dataPtr;
#if 0
printf("yyMonth %d, yyDay %d, yyDayOfYear %d, yyHour %d, yyMinutes %d, yySeconds %" TCL_LL_MODIFIER "d, "
"yySecondOfDay %" TCL_LL_MODIFIER "d, sec %" TCL_LL_MODIFIER "d, daySec %" TCL_LL_MODIFIER "d, tzOffset %d\n",
yyMonth, yyDay, yydate.dayOfYear, yyHour, yyMinutes, yySeconds,
yySecondOfDay, yydate.localSeconds, yydate.localSeconds % SECONDS_PER_DAY,
yydate.tzOffset);
#endif
if (!(stage & CLF_VALIDATE_S1) || !(opts->flags & CLF_VALIDATE_S1)) {
goto stage_2;
}
opts->flags &= ~CLF_VALIDATE_S1; /* stage 1 is done */
/* first year (used later in hath / daysInPriorMonths) */
if ((info->flags & (CLF_YEAR | CLF_ISO8601YEAR))) {
if ((info->flags & CLF_ISO8601YEAR)) {
if (yydate.iso8601Year < dataPtr->validMinYear
|| yydate.iso8601Year > dataPtr->validMaxYear) {
errMsg = "invalid iso year";
errCode = "iso year";
goto error;
}
}
if (info->flags & CLF_YEAR) {
if (yyYear < dataPtr->validMinYear
|| yyYear > dataPtr->validMaxYear) {
errMsg = "invalid year";
errCode = "year";
goto error;
}
} else if ((info->flags & CLF_ISO8601YEAR)) {
yyYear = yydate.iso8601Year; /* used to recognize leap */
}
if ((info->flags & (CLF_ISO8601YEAR | CLF_YEAR))
== (CLF_ISO8601YEAR | CLF_YEAR)) {
if (yyYear != yydate.iso8601Year) {
errMsg = "ambiguous year";
errCode = "year";
goto error;
}
}
}
/* and month (used later in hath) */
if (info->flags & CLF_MONTH) {
if (yyMonth < 1 || yyMonth > 12) {
errMsg = "invalid month";
errCode = "month";
goto error;
}
}
/* day of month */
if (info->flags & (CLF_DAYOFMONTH|CLF_DAYOFWEEK)) {
if (yyDay < 1 || yyDay > 31) {
errMsg = "invalid day";
errCode = "day";
goto error;
}
if ((info->flags & CLF_MONTH)) {
const int *h = hath[IsGregorianLeapYear(&yydate)];
if (yyDay > h[yyMonth - 1]) {
errMsg = "invalid day";
errCode = "day";
goto error;
}
}
}
if (info->flags & CLF_DAYOFYEAR) {
if (yydate.dayOfYear < 1
|| yydate.dayOfYear > daysInPriorMonths[IsGregorianLeapYear(&yydate)][12]) {
errMsg = "invalid day of year";
errCode = "day of year";
goto error;
}
}
/* mmdd !~ ddd */
if ((info->flags & (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH))
== (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH)) {
if (!tempCpyFlg) {
memcpy(&temp, &yydate, sizeof(temp));
tempCpyFlg = 1;
}
GetJulianDayFromEraYearDay(&temp, GREGORIAN_CHANGE_DATE);
if (temp.julianDay != yydate.julianDay) {
errMsg = "ambiguous day";
errCode = "day";
goto error;
}
}
if (info->flags & CLF_TIME) {
/* hour */
if (yyHour < 0 || yyHour > ((yyMeridian == MER24) ? 23 : 12)) {
/* allow 24:00:00 as special case, see [aee9f2b916afd976] */
if (yyMeridian == MER24 && yyHour == 24) {
if (yyMinutes != 0 || yySeconds != 0) {
errMsg = "invalid time";
errCode = "time";
goto error;
}
/* 24:00 is next day 00:00, correct day of week if given */
if (info->flags & CLF_DAYOFWEEK) {
if (++yyDayOfWeek > 7) { /* Mon .. Sun == 1 .. 7 */
yyDayOfWeek = 1;
}
}
} else {
errMsg = "invalid time (hour)";
errCode = "hour";
goto error;
}
}
/* minutes */
if (yyMinutes < 0 || yyMinutes > 59) {
errMsg = "invalid time (minutes)";
errCode = "minutes";
goto error;
}
/* oldscan could return secondOfDay -1 by invalid time (see ToSeconds) */
if (yySeconds < 0 || yySeconds > 59 || yySecondOfDay <= -1) {
errMsg = "invalid time";
errCode = "seconds";
goto error;
}
}
if (!(stage & CLF_VALIDATE_S2) || !(opts->flags & CLF_VALIDATE_S2)) {
return TCL_OK;
}
/*
* Further tests expected ready calculated julianDay (inclusive relative),
* and time-zone conversion (local to UTC time).
*/
stage_2:
opts->flags &= ~CLF_VALIDATE_S2; /* stage 2 is done */
/* time, regarding the modifications by the time-zone (looks for given time
* in between DST-time hole, so does not exist in this time-zone) */
if (info->flags & CLF_TIME) {
/*
* we don't need to do the backwards time-conversion (UTC to local) and
* compare results, because the after conversion (local to UTC) we
* should have valid localSeconds (was not invalidated to TCL_INV_SECONDS),
* so if it was invalidated - invalid time, outside the time-zone (in DST-hole)
*/
if (yydate.localSeconds == TCL_INV_SECONDS) {
errMsg = "invalid time (does not exist in this time-zone)";
errCode = "out-of-time";
goto error;
}
}
/* day of week */
if (info->flags & CLF_DAYOFWEEK) {
if (!tempCpyFlg) {
memcpy(&temp, &yydate, sizeof(temp));
tempCpyFlg = 1;
}
GetYearWeekDay(&temp, GREGORIAN_CHANGE_DATE);
if (temp.dayOfWeek != yyDayOfWeek) {
errMsg = "invalid day of week";
errCode = "day of week";
goto error;
}
}
return TCL_OK;
error:
Tcl_SetObjResult(opts->interp, Tcl_ObjPrintf(
"unable to convert input string: %s", errMsg));
Tcl_SetErrorCode(opts->interp, "CLOCK", "invInpStr", errCode, (char *)NULL);
return TCL_ERROR;
}
/*----------------------------------------------------------------------
*
* ClockFreeScan --
*
* Used by ClockScanObjCmd for free scanning without format.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
ClockFreeScan(
DateInfo *info, /* Date fields used for parsing & converting
* simultaneously a yy-parse structure of the
* TclClockFreeScan */
Tcl_Obj *strObj, /* String containing the time to scan */
ClockFmtScnCmdArgs *opts) /* Command options */
{
Tcl_Interp *interp = opts->interp;
ClockClientData *dataPtr = opts->dataPtr;
int ret = TCL_ERROR;
/*
* Parse the date. The parser will fill a structure "info" with date,
* time, time zone, relative month/day/seconds, relative weekday, ordinal
* month.
* Notice that many yy-defines point to values in the "info" or "date"
* structure, e. g. yySecondOfDay -> info->date.secondOfDay or
* yyMonth -> info->date.month (same as yydate.month)
*/
yyInput = TclGetString(strObj);
if (TclClockFreeScan(interp, info) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to convert date-time string \"%s\": %s",
TclGetString(strObj), Tcl_GetString(Tcl_GetObjResult(interp))));
goto done;
}
/*
* If the caller supplied a date in the string, update the date with
* the value. If the caller didn't specify a time with the date, default to
* midnight.
*/
if (info->flags & CLF_YEAR) {
if (yyYear < 100) {
if (yyYear >= dataPtr->yearOfCenturySwitch) {
yyYear -= 100;
}
yyYear += dataPtr->currentYearCentury;
}
yydate.isBce = 0;
info->flags |= CLF_ASSEMBLE_JULIANDAY|CLF_ASSEMBLE_SECONDS;
}
/*
* If the caller supplied a time zone in the string, make it into a time
* zone indicator of +-hhmm and setup this time zone.
*/
if (info->flags & CLF_ZONE) {
if (yyTimezone || !yyDSTmode) {
/* Real time zone from numeric zone */
Tcl_Obj *tzObjStor = NULL;
int minEast = -yyTimezone;
int dstFlag = 1 - yyDSTmode;
tzObjStor = ClockFormatNumericTimeZone(
60 * minEast + 3600 * dstFlag);
Tcl_IncrRefCount(tzObjStor);
opts->timezoneObj = ClockSetupTimeZone(dataPtr, interp, tzObjStor);
Tcl_DecrRefCount(tzObjStor);
} else {
/* simplest case - GMT / UTC */
opts->timezoneObj = ClockSetupTimeZone(dataPtr, interp,
dataPtr->literals[LIT_GMT]);
}
if (opts->timezoneObj == NULL) {
goto done;
}
// TclSetObjRef(yydate.tzName, opts->timezoneObj);
info->flags |= CLF_ASSEMBLE_SECONDS;
}
/*
* For freescan apply validation rules (stage 1) before mixed with
* relative time (otherwise always valid recalculated date & time).
*/
if (opts->flags & CLF_VALIDATE) {
if (ClockValidDate(info, opts, CLF_VALIDATE_S1) != TCL_OK) {
goto done;
}
}
/*
* Assemble date, time, zone into seconds-from-epoch
*/
if ((info->flags & (CLF_TIME | CLF_HAVEDATE)) == CLF_HAVEDATE) {
yySecondOfDay = 0;
info->flags |= CLF_ASSEMBLE_SECONDS;
} else if (info->flags & CLF_TIME) {
yySecondOfDay = ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian);
info->flags |= CLF_ASSEMBLE_SECONDS;
} else if ((info->flags & (CLF_DAYOFWEEK | CLF_HAVEDATE)) == CLF_DAYOFWEEK
|| (info->flags & CLF_ORDINALMONTH)
|| ((info->flags & CLF_RELCONV)
&& (yyRelMonth != 0 || yyRelDay != 0))) {
yySecondOfDay = 0;
info->flags |= CLF_ASSEMBLE_SECONDS;
} else {
yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY;
}
/*
* Do relative times
*/
ret = ClockCalcRelTime(info);
/* Free scanning completed - date ready */
done:
return ret;
}
/*----------------------------------------------------------------------
*
* ClockCalcRelTime --
*
* Used for calculating of relative times.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
ClockCalcRelTime(
DateInfo *info) /* Date fields used for converting */
{
int prevDayOfWeek = yyDayOfWeek; /* preserve unchanged day of week */
/*
* Because some calculations require in-between conversion of the
* julian day, we can repeat this processing multiple times
*/
repeat_rel:
if (info->flags & CLF_RELCONV) {
/*
* Relative conversion normally possible in UTC time only, because
* of possible wrong local time increment if ignores in-between DST-hole.
* (see test-cases clock-34.53, clock-34.54).
* So increment date in julianDay, but time inside day in UTC (seconds).
*/
/* add months (or years in months) */
if (yyRelMonth != 0) {
int m, h;
/* if needed extract year, month, etc. again */
if (info->flags & CLF_ASSEMBLE_DATE) {
GetGregorianEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
GetMonthDay(&yydate);
GetYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE);
info->flags &= ~CLF_ASSEMBLE_DATE;
}
/* add the requisite number of months */
yyMonth += yyRelMonth - 1;
yyYear += yyMonth / 12;
m = yyMonth % 12;
/* compiler fix for negative offs - wrap y, m = (0, -1) -> (-1, 11) */
if (m < 0) {
yyYear--;
m = 12 + m;
}
yyMonth = m + 1;
/* if the day doesn't exist in the current month, repair it */
h = hath[IsGregorianLeapYear(&yydate)][m];
if (yyDay > h) {
yyDay = h;
}
/* on demand (lazy) assemble julianDay using new year, month, etc. */
info->flags |= CLF_ASSEMBLE_JULIANDAY | CLF_ASSEMBLE_SECONDS;
yyRelMonth = 0;
}
/* add days (or other parts aligned to days) */
if (yyRelDay) {
/* assemble julianDay using new year, month, etc. */
if (info->flags & CLF_ASSEMBLE_JULIANDAY) {
GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE);
info->flags &= ~CLF_ASSEMBLE_JULIANDAY;
}
yydate.julianDay += yyRelDay;
/* julianDay was changed, on demand (lazy) extract year, month, etc. again */
info->flags |= CLF_ASSEMBLE_DATE|CLF_ASSEMBLE_SECONDS;
yyRelDay = 0;
}
/* relative time (seconds), if exceeds current date, do the day conversion and
* leave rest of the increment in yyRelSeconds to add it hereafter in UTC seconds */
if (yyRelSeconds) {
Tcl_WideInt newSecs = yySecondOfDay + yyRelSeconds;
/* if seconds increment outside of current date, increment day */
if (newSecs / SECONDS_PER_DAY != yySecondOfDay / SECONDS_PER_DAY) {
yyRelDay += newSecs / SECONDS_PER_DAY;
yySecondOfDay = 0;
yyRelSeconds = newSecs % SECONDS_PER_DAY;
goto repeat_rel;
}
}
info->flags &= ~CLF_RELCONV;
}
/*
* Do relative (ordinal) month
*/
if (info->flags & CLF_ORDINALMONTH) {
int monthDiff;
/* if needed extract year, month, etc. again */
if (info->flags & CLF_ASSEMBLE_DATE) {
GetGregorianEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
GetMonthDay(&yydate);
GetYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE);
info->flags &= ~CLF_ASSEMBLE_DATE;
}
if (yyMonthOrdinalIncr > 0) {
monthDiff = yyMonthOrdinal - yyMonth;
if (monthDiff <= 0) {
monthDiff += 12;
}
yyMonthOrdinalIncr--;
} else {
monthDiff = yyMonth - yyMonthOrdinal;
if (monthDiff >= 0) {
monthDiff -= 12;
}
yyMonthOrdinalIncr++;
}
/* process it further via relative times */
yyYear += yyMonthOrdinalIncr;
yyRelMonth += monthDiff;
info->flags &= ~CLF_ORDINALMONTH;
info->flags |= CLF_RELCONV|CLF_ASSEMBLE_JULIANDAY|CLF_ASSEMBLE_SECONDS;
goto repeat_rel;
}
/*
* Do relative weekday
*/
if ((info->flags & (CLF_DAYOFWEEK|CLF_HAVEDATE)) == CLF_DAYOFWEEK) {
/* restore scanned day of week */
yyDayOfWeek = prevDayOfWeek;
/* if needed assemble julianDay now */
if (info->flags & CLF_ASSEMBLE_JULIANDAY) {
GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE);
info->flags &= ~CLF_ASSEMBLE_JULIANDAY;
}
yydate.isBce = 0;
yydate.julianDay = WeekdayOnOrBefore(yyDayOfWeek, yydate.julianDay + 6)
+ 7 * yyDayOrdinal;
if (yyDayOrdinal > 0) {
yydate.julianDay -= 7;
}
info->flags |= CLF_ASSEMBLE_DATE|CLF_ASSEMBLE_SECONDS;
}
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* ClockWeekdaysOffs --
*
* Get offset in days for the number of week days corresponding the
* given day of week (skipping Saturdays and Sundays).
*
*
* Results:
* Returns a day increment adjusted the given weekdays
*
*----------------------------------------------------------------------
*/
static inline int
ClockWeekdaysOffs(
int dayOfWeek,
int offs)
{
int weeks, resDayOfWeek;
/* offset in days */
weeks = offs / 5;
offs = offs % 5;
/* compiler fix for negative offs - wrap (0, -1) -> (-1, 4) */
if (offs < 0) {
weeks--;
offs = 5 + offs;
}
offs += 7 * weeks;
/* resulting day of week */
{
int day = (offs % 7);
/* compiler fix for negative offs - wrap (0, -1) -> (-1, 6) */
if (day < 0) {
day = 7 + day;
}
resDayOfWeek = dayOfWeek + day;
}
/* adjust if we start from a weekend */
if (dayOfWeek > 5) {
int adj = 5 - dayOfWeek;
offs += adj;
resDayOfWeek += adj;
}
/* adjust if we end up on a weekend */
if (resDayOfWeek > 5) {
offs += 2;
}
return offs;
}
/*----------------------------------------------------------------------
*
* ClockAddObjCmd -- , clock add --
*
* Adds an offset to a given time.
*
* Refer to the user documentation to see what it exactly does.
*
* Syntax:
* clock add clockval ?count unit?... ?-option value?
*
* Parameters:
* clockval -- Starting time value
* count -- Amount of a unit of time to add
* unit -- Unit of time to add, must be one of:
* years year months month weeks week
* days day hours hour minutes minute
* seconds second
*
* Options:
* -gmt BOOLEAN
* Flag synonymous with '-timezone :GMT'
* -timezone ZONE
* Name of the time zone in which calculations are to be done.
* -locale NAME
* Name of the locale in which calculations are to be done.
* Used to determine the Gregorian change date.
*
* Results:
* Returns a standard Tcl result with the given time adjusted
* by the given offset(s) in order.
*
* Notes:
* It is possible that adding a number of months or years will adjust the
* day of the month as well. For instance, the time at one month after
* 31 January is either 28 or 29 February, because February has fewer
* than 31 days.
*
*----------------------------------------------------------------------
*/
int
ClockAddObjCmd(
void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter values */
{
static const char *syntax = "clock add clockval|now ?number units?..."
"?-gmt boolean? "
"?-locale LOCALE? ?-timezone ZONE?";
ClockClientData *dataPtr = (ClockClientData *)clientData;
int ret;
ClockFmtScnCmdArgs opts; /* Format, locale, timezone and base */
DateInfo yy; /* Common structure used for parsing */
DateInfo *info = &yy;
/* add "week" to units also (because otherwise ambiguous) */
static const char *const units[] = {
"years", "months", "week", "weeks",
"days", "weekdays",
"hours", "minutes", "seconds",
NULL
};
enum unitInd {
CLC_ADD_YEARS, CLC_ADD_MONTHS, CLC_ADD_WEEK, CLC_ADD_WEEKS,
CLC_ADD_DAYS, CLC_ADD_WEEKDAYS,
CLC_ADD_HOURS, CLC_ADD_MINUTES, CLC_ADD_SECONDS
};
int unitIndex; /* Index of an option. */
Tcl_Size i;
Tcl_WideInt offs;
/* even number of arguments */
if ((objc & 1) == 1) {
Tcl_WrongNumArgs(interp, 0, objv, syntax);
Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL);
return TCL_ERROR;
}
ClockInitDateInfo(&yy);
/*
* Extract values for the keywords.
*/
ClockInitFmtScnArgs(dataPtr, interp, &opts);
ret = ClockParseFmtScnArgs(&opts, &yy.date, objc, objv,
CLC_OP_ADD, "-gmt, -locale, or -timezone");
if (ret != TCL_OK) {
goto done;
}
/* time together as seconds of the day */
yySecondOfDay = yySeconds = yydate.localSeconds % SECONDS_PER_DAY;
/* seconds are in localSeconds (relative base date), so reset time here */
yyHour = 0;
yyMinutes = 0;
yyMeridian = MER24;
ret = TCL_ERROR;
/*
* Find each offset and process date increment
*/
for (i = 2; i < objc; i+=2) {
/* bypass not integers (options, allready processed above in ClockParseFmtScnArgs) */
if (TclGetWideIntFromObj(NULL, objv[i], &offs) != TCL_OK) {
continue;
}
/* get unit */
if (Tcl_GetIndexFromObj(interp, objv[i + 1], units, "unit", 0,
&unitIndex) != TCL_OK) {
goto done;
}
if (TclHasInternalRep(objv[i], &tclBignumType)
|| offs > (unitIndex < CLC_ADD_HOURS ? 0x7fffffff : TCL_MAX_SECONDS)
|| offs < (unitIndex < CLC_ADD_HOURS ? -0x7fffffff : TCL_MIN_SECONDS)) {
Tcl_SetObjResult(interp, dataPtr->literals[LIT_INTEGER_VALUE_TOO_LARGE]);
goto done;
}
/* nothing to do if zero quantity */
if (!offs) {
continue;
}
/* if in-between conversion needed (already have relative date/time),
* correct date info, because the date may be changed,
* so refresh it now */
if ((info->flags & CLF_RELCONV)
&& (unitIndex == CLC_ADD_WEEKDAYS
/* some months can be shorter as another */
|| yyRelMonth || yyRelDay
/* day changed */
|| yySeconds + yyRelSeconds > SECONDS_PER_DAY
|| yySeconds + yyRelSeconds < 0)) {
if (ClockCalcRelTime(info) != TCL_OK) {
goto done;
}
}
/* process increment by offset + unit */
info->flags |= CLF_RELCONV;
switch (unitIndex) {
case CLC_ADD_YEARS:
yyRelMonth += offs * 12;
break;
case CLC_ADD_MONTHS:
yyRelMonth += offs;
break;
case CLC_ADD_WEEK:
case CLC_ADD_WEEKS:
yyRelDay += offs * 7;
break;
case CLC_ADD_DAYS:
yyRelDay += offs;
break;
case CLC_ADD_WEEKDAYS:
/* add number of week days (skipping Saturdays and Sundays)
* to a relative days value. */
offs = ClockWeekdaysOffs(yy.date.dayOfWeek, offs);
yyRelDay += offs;
break;
case CLC_ADD_HOURS:
yyRelSeconds += offs * 60 * 60;
break;
case CLC_ADD_MINUTES:
yyRelSeconds += offs * 60;
break;
case CLC_ADD_SECONDS:
yyRelSeconds += offs;
break;
}
}
/*
* Do relative times (if not yet already processed interim):
*/
if (info->flags & CLF_RELCONV) {
if (ClockCalcRelTime(info) != TCL_OK) {
goto done;
}
}
/* Convert date info structure into UTC seconds */
ret = ClockScanCommit(&yy, &opts);
done:
TclUnsetObjRef(yy.date.tzName);
if (ret != TCL_OK) {
return ret;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(yy.date.seconds));
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* ClockSecondsObjCmd -
*
* Returns a count of microseconds since the epoch.
|
| ︙ | ︙ | |||
1996 1997 1998 1999 2000 2001 2002 |
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | | | < < | < | | | | | > > > | > | | | | | | > | > | > | > > > | > | < < | < < < < < < < < < < < | | < | | < | | < < | > | 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 |
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 0, objv, "clock seconds");
return TCL_ERROR;
}
Tcl_GetTime(&now);
TclNewUIntObj(timeObj, (Tcl_WideUInt)now.sec);
Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ClockSafeCatchCmd --
*
* Same as "::catch" command but avoids overwriting of interp state.
*
* See [554117edde] for more info (and proper solution).
*
*----------------------------------------------------------------------
*/
int
ClockSafeCatchCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
typedef struct {
int status; /* return code status */
int flags; /* Each remaining field saves the */
int returnLevel; /* corresponding field of the Interp */
int returnCode; /* struct. These fields taken together are */
Tcl_Obj *errorInfo; /* the "state" of the interp. */
Tcl_Obj *errorCode;
Tcl_Obj *returnOpts;
Tcl_Obj *objResult;
Tcl_Obj *errorStack;
int resetErrorStack;
} InterpState;
Interp *iPtr = (Interp *)interp;
int ret, flags = 0;
InterpState *statePtr;
if (objc == 1) {
/* wrong # args : */
return Tcl_CatchObjCmd(NULL, interp, objc, objv);
}
statePtr = (InterpState *)Tcl_SaveInterpState(interp, 0);
if (!statePtr->errorInfo) {
/* todo: avoid traced get of errorInfo here */
TclInitObjRef(statePtr->errorInfo,
Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, 0));
flags |= ERR_LEGACY_COPY;
}
if (!statePtr->errorCode) {
/* todo: avoid traced get of errorCode here */
TclInitObjRef(statePtr->errorCode,
Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, 0));
flags |= ERR_LEGACY_COPY;
}
/* original catch */
ret = Tcl_CatchObjCmd(NULL, interp, objc, objv);
if (ret == TCL_ERROR) {
Tcl_DiscardInterpState((Tcl_InterpState)statePtr);
return TCL_ERROR;
}
/* overwrite result in state with catch result */
TclSetObjRef(statePtr->objResult, Tcl_GetObjResult(interp));
/* set result (together with restore state) to interpreter */
(void) Tcl_RestoreInterpState(interp, (Tcl_InterpState)statePtr);
/* todo: unless ERR_LEGACY_COPY not set in restore (branch [bug-554117edde] not merged yet) */
iPtr->flags |= (flags & ERR_LEGACY_COPY);
return ret;
}
/*
*----------------------------------------------------------------------
*
* TzsetIfNecessary --
*
* Calls the tzset() library function if the contents of the TZ
* environment variable has changed.
*
* Results:
* An epoch counter to allow efficient checking if the timezone has
* changed.
*
* Side effects:
* Calls tzset.
*
*----------------------------------------------------------------------
*/
#ifdef _WIN32
#define getenv(x) _wgetenv(L##x)
#else
#define WCHAR char
#define wcslen strlen
#define wcscmp strcmp
#define wcscpy strcpy
#endif
#define TZ_INIT_MARKER ((WCHAR *) INT2PTR(-1))
typedef struct ClockTzStatic {
WCHAR *was; /* Previous value of TZ. */
#if TCL_MAJOR_VERSION > 8
long long lastRefresh; /* Used for latency before next refresh. */
#else
long lastRefresh; /* Used for latency before next refresh. */
#endif
size_t epoch; /* Epoch, signals that TZ changed. */
size_t envEpoch; /* Last env epoch, for faster signaling,
* that TZ changed via TCL */
} ClockTzStatic;
static ClockTzStatic tz = { /* Global timezone info; protected by
* clockMutex.*/
TZ_INIT_MARKER, 0, 0, 0
};
static size_t
TzsetIfNecessary(void)
{
const WCHAR *tzNow; /* Current value of TZ. */
Tcl_Time now; /* Current time. */
size_t epoch; /* The tz.epoch that the TZ was read at. */
/*
* Prevent performance regression on some platforms by resolving of system time zone:
* small latency for check whether environment was changed (once per second)
* no latency if environment was changed with tcl-env (compare both epoch values)
*/
Tcl_GetTime(&now);
if (now.sec == tz.lastRefresh && tz.envEpoch == TclEnvEpoch) {
return tz.epoch;
}
tz.envEpoch = TclEnvEpoch;
tz.lastRefresh = now.sec;
/* check in lock */
Tcl_MutexLock(&clockMutex);
tzNow = getenv("TCL_TZ");
if (tzNow == NULL) {
tzNow = getenv("TZ");
}
if (tzNow != NULL && (tz.was == NULL || tz.was == TZ_INIT_MARKER
|| wcscmp(tzNow, tz.was) != 0)) {
tzset();
if (tz.was != NULL && tz.was != TZ_INIT_MARKER) {
Tcl_Free(tz.was);
}
tz.was = (WCHAR *)Tcl_Alloc(sizeof(WCHAR) * (wcslen(tzNow) + 1));
wcscpy(tz.was, tzNow);
epoch = ++tz.epoch;
} else if (tzNow == NULL && tz.was != NULL) {
tzset();
if (tz.was != TZ_INIT_MARKER) {
Tcl_Free(tz.was);
}
tz.was = NULL;
epoch = ++tz.epoch;
} else {
epoch = tz.epoch;
}
Tcl_MutexUnlock(&clockMutex);
return epoch;
}
static void
ClockFinalize(
TCL_UNUSED(void *))
{
ClockFrmScnFinalize();
if (tz.was && tz.was != TZ_INIT_MARKER) {
Tcl_Free(tz.was);
}
Tcl_MutexFinalize(&clockMutex);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Added generic/tclClockFmt.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 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 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 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 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 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 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 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 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 |
/*
* tclClockFmt.c --
*
* Contains the date format (and scan) routines. This code is back-ported
* from the time and date facilities of tclSE engine, by Serg G. Brester.
*
* Copyright (c) 2015 by Sergey G. Brester aka sebres. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclStrIdxTree.h"
#include "tclDate.h"
/*
* Miscellaneous forward declarations and functions used within this file
*/
static void ClockFmtObj_DupInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void ClockFmtObj_FreeInternalRep(Tcl_Obj *objPtr);
static int ClockFmtObj_SetFromAny(Tcl_Interp *, Tcl_Obj *objPtr);
static void ClockFmtObj_UpdateString(Tcl_Obj *objPtr);
static Tcl_HashEntry * ClockFmtScnStorageAllocProc(Tcl_HashTable *, void *keyPtr);
static void ClockFmtScnStorageFreeProc(Tcl_HashEntry *hPtr);
static void ClockFmtScnStorageDelete(ClockFmtScnStorage *fss);
TCL_DECLARE_MUTEX(ClockFmtMutex); /* Serializes access to common format list. */
#ifndef TCL_CLOCK_FULL_COMPAT
#define TCL_CLOCK_FULL_COMPAT 1
#endif
/*
* Derivation of tclStringHashKeyType with extra memory management trickery.
*/
static const Tcl_HashKeyType ClockFmtScnStorageHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
TclHashStringKey, /* hashKeyProc */
TclCompareStringKeys, /* compareKeysProc */
ClockFmtScnStorageAllocProc, /* allocEntryProc */
ClockFmtScnStorageFreeProc /* freeEntryProc */
};
#define IntFieldAt(info, offset) \
((int *) (((char *) (info)) + (offset)))
#define WideFieldAt(info, offset) \
((Tcl_WideInt *) (((char *) (info)) + (offset)))
/*
* Clock scan and format facilities.
*/
/*
*----------------------------------------------------------------------
*
* Clock_str2int, Clock_str2wideInt --
*
* Fast inline-convertion of string to signed int or wide int by given
* start/end.
*
* The given string should contain numbers chars only (because already
* pre-validated within parsing routines)
*
* Results:
* Returns a standard Tcl result.
* TCL_OK - by successful conversion, TCL_ERROR by (wide) int overflow
*
*----------------------------------------------------------------------
*/
static inline void
Clock_str2int_no(
int *out,
const char *p,
const char *e,
int sign)
{
/* assert(e <= p + 10); */
int val = 0;
/* overflow impossible for 10 digits ("9..9"), so no needs to check at all */
while (p < e) { /* never overflows */
val = val * 10 + (*p++ - '0');
}
if (sign < 0) {
val = -val;
}
*out = val;
}
static inline void
Clock_str2wideInt_no(
Tcl_WideInt *out,
const char *p,
const char *e,
int sign)
{
/* assert(e <= p + 18); */
Tcl_WideInt val = 0;
/* overflow impossible for 18 digits ("9..9"), so no needs to check at all */
while (p < e) { /* never overflows */
val = val * 10 + (*p++ - '0');
}
if (sign < 0) {
val = -val;
}
*out = val;
}
/* int & Tcl_WideInt overflows may happens here (expected case) */
#if (defined(__GNUC__) || defined(__GNUG__)) && !defined(__clang__)
# pragma GCC optimize("no-trapv")
#endif
static inline int
Clock_str2int(
int *out,
const char *p,
const char *e,
int sign)
{
int val = 0;
/* overflow impossible for 10 digits ("9..9"), so no needs to check before */
const char *eNO = p + 10;
if (eNO > e) {
eNO = e;
}
while (p < eNO) { /* never overflows */
val = val * 10 + (*p++ - '0');
}
if (sign >= 0) {
while (p < e) { /* check for overflow */
int prev = val;
val = val * 10 + (*p++ - '0');
if (val / 10 < prev) {
return TCL_ERROR;
}
}
} else {
val = -val;
while (p < e) { /* check for overflow */
int prev = val;
val = val * 10 - (*p++ - '0');
if (val / 10 > prev) {
return TCL_ERROR;
}
}
}
*out = val;
return TCL_OK;
}
static inline int
Clock_str2wideInt(
Tcl_WideInt *out,
const char *p,
const char *e,
int sign)
{
Tcl_WideInt val = 0;
/* overflow impossible for 18 digits ("9..9"), so no needs to check before */
const char *eNO = p + 18;
if (eNO > e) {
eNO = e;
}
while (p < eNO) { /* never overflows */
val = val * 10 + (*p++ - '0');
}
if (sign >= 0) {
while (p < e) { /* check for overflow */
Tcl_WideInt prev = val;
val = val * 10 + (*p++ - '0');
if (val / 10 < prev) {
return TCL_ERROR;
}
}
} else {
val = -val;
while (p < e) { /* check for overflow */
Tcl_WideInt prev = val;
val = val * 10 - (*p++ - '0');
if (val / 10 > prev) {
return TCL_ERROR;
}
}
}
*out = val;
return TCL_OK;
}
int
TclAtoWIe(
Tcl_WideInt *out,
const char *p,
const char *e,
int sign)
{
return Clock_str2wideInt(out, p, e, sign);
}
#if (defined(__GNUC__) || defined(__GNUG__)) && !defined(__clang__)
# pragma GCC reset_options
#endif
/*
*----------------------------------------------------------------------
*
* Clock_itoaw, Clock_witoaw --
*
* Fast inline-convertion of signed int or wide int to string, using
* given padding with specified padchar and width (or without padding).
*
* This is a very fast replacement for sprintf("%02d").
*
* Results:
* Returns position in buffer after end of conversion result.
*
*----------------------------------------------------------------------
*/
static inline char *
Clock_itoaw(
char *buf,
int val,
char padchar,
unsigned short width)
{
char *p;
static const int wrange[] = {
1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000
};
/* positive integer */
if (val >= 0) {
/* check resp. recalculate width */
while (width <= 9 && val >= wrange[width]) {
width++;
}
/* number to string backwards */
p = buf + width;
*p-- = '\0';
do {
char c = val % 10;
val /= 10;
*p-- = '0' + c;
} while (val > 0);
/* filling with pad-char */
while (p >= buf) {
*p-- = padchar;
}
return buf + width;
}
/* negative integer */
if (!width) {
width++;
}
/* check resp. recalculate width (regarding sign) */
width--;
while (width <= 9 && val <= -wrange[width]) {
width++;
}
width++;
/* number to string backwards */
p = buf + width;
*p-- = '\0';
/* differentiate platforms with -1 % 10 == 1 and -1 % 10 == -1 */
if (-1 % 10 == -1) {
do {
char c = val % 10;
val /= 10;
*p-- = '0' - c;
} while (val < 0);
} else {
do {
char c = val % 10;
val /= 10;
*p-- = '0' + c;
} while (val < 0);
}
/* sign by 0 padding */
if (padchar != '0') {
*p-- = '-';
}
/* filling with pad-char */
while (p >= buf + 1) {
*p-- = padchar;
}
/* sign by non 0 padding */
if (padchar == '0') {
*p = '-';
}
return buf + width;
}
char *
TclItoAw(
char *buf,
int val,
char padchar,
unsigned short width)
{
return Clock_itoaw(buf, val, padchar, width);
}
static inline char *
Clock_witoaw(
char *buf,
Tcl_WideInt val,
char padchar,
unsigned short width)
{
char *p;
static const int wrange[] = {
1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000
};
/* positive integer */
if (val >= 0) {
/* check resp. recalculate width */
if (val >= 10000000000LL) {
Tcl_WideInt val2 = val / 10000000000LL;
while (width <= 9 && val2 >= wrange[width]) {
width++;
}
width += 10;
} else {
while (width <= 9 && val >= wrange[width]) {
width++;
}
}
/* number to string backwards */
p = buf + width;
*p-- = '\0';
do {
char c = (val % 10);
val /= 10;
*p-- = '0' + c;
} while (val > 0);
/* filling with pad-char */
while (p >= buf) {
*p-- = padchar;
}
return buf + width;
}
/* negative integer */
if (!width) {
width++;
}
/* check resp. recalculate width (regarding sign) */
width--;
if (val <= -10000000000LL) {
Tcl_WideInt val2 = val / 10000000000LL;
while (width <= 9 && val2 <= -wrange[width]) {
width++;
}
width += 10;
} else {
while (width <= 9 && val <= -wrange[width]) {
width++;
}
}
width++;
/* number to string backwards */
p = buf + width;
*p-- = '\0';
/* differentiate platforms with -1 % 10 == 1 and -1 % 10 == -1 */
if (-1 % 10 == -1) {
do {
char c = val % 10;
val /= 10;
*p-- = '0' - c;
} while (val < 0);
} else {
do {
char c = val % 10;
val /= 10;
*p-- = '0' + c;
} while (val < 0);
}
/* sign by 0 padding */
if (padchar != '0') {
*p-- = '-';
}
/* filling with pad-char */
while (p >= buf + 1) {
*p-- = padchar;
}
/* sign by non 0 padding */
if (padchar == '0') {
*p = '-';
}
return buf + width;
}
/*
* Global GC as LIFO for released scan/format object storages.
*
* Used to holds last released CLOCK_FMT_SCN_STORAGE_GC_SIZE formats
* (after last reference from Tcl-object will be removed). This is helpful
* to avoid continuous (re)creation and compiling by some dynamically resp.
* variable format objects, that could be often reused.
*
* As long as format storage is used resp. belongs to GC, it takes place in
* FmtScnHashTable also.
*/
#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
static struct ClockFmtScnStorage_GC {
ClockFmtScnStorage *stackPtr;
ClockFmtScnStorage *stackBound;
unsigned count;
} ClockFmtScnStorage_GC = {NULL, NULL, 0};
/*
*----------------------------------------------------------------------
*
* ClockFmtScnStorageGC_In --
*
* Adds an format storage object to GC.
*
* If current GC is full (size larger as CLOCK_FMT_SCN_STORAGE_GC_SIZE)
* this removes last unused storage at begin of GC stack (LIFO).
*
* Assumes caller holds the ClockFmtMutex.
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static inline void
ClockFmtScnStorageGC_In(
ClockFmtScnStorage *entry)
{
/* add new entry */
TclSpliceIn(entry, ClockFmtScnStorage_GC.stackPtr);
if (ClockFmtScnStorage_GC.stackBound == NULL) {
ClockFmtScnStorage_GC.stackBound = entry;
}
ClockFmtScnStorage_GC.count++;
/* if GC ist full */
if (ClockFmtScnStorage_GC.count > CLOCK_FMT_SCN_STORAGE_GC_SIZE) {
/* GC stack is LIFO: delete first inserted entry */
ClockFmtScnStorage *delEnt = ClockFmtScnStorage_GC.stackBound;
ClockFmtScnStorage_GC.stackBound = delEnt->prevPtr;
TclSpliceOut(delEnt, ClockFmtScnStorage_GC.stackPtr);
ClockFmtScnStorage_GC.count--;
delEnt->prevPtr = delEnt->nextPtr = NULL;
/* remove it now */
ClockFmtScnStorageDelete(delEnt);
}
}
/*
*----------------------------------------------------------------------
*
* ClockFmtScnStorage_GC_Out --
*
* Restores (for reusing) given format storage object from GC.
*
* Assumes caller holds the ClockFmtMutex.
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static inline void
ClockFmtScnStorage_GC_Out(
ClockFmtScnStorage *entry)
{
TclSpliceOut(entry, ClockFmtScnStorage_GC.stackPtr);
ClockFmtScnStorage_GC.count--;
if (ClockFmtScnStorage_GC.stackBound == entry) {
ClockFmtScnStorage_GC.stackBound = entry->prevPtr;
}
entry->prevPtr = entry->nextPtr = NULL;
}
#endif
/*
* Global format storage hash table of type ClockFmtScnStorageHashKeyType
* (contains list of scan/format object storages, shared across all threads).
*
* Used for fast searching by format string.
*/
static Tcl_HashTable FmtScnHashTable;
static int initialized = 0;
/*
* Wrappers between pointers to hash entry and format storage object
*/
static inline Tcl_HashEntry *
HashEntry4FmtScn(
ClockFmtScnStorage *fss)
{
return (Tcl_HashEntry*)(fss + 1);
}
static inline ClockFmtScnStorage *
FmtScn4HashEntry(
Tcl_HashEntry *hKeyPtr)
{
return (ClockFmtScnStorage*)(((char*)hKeyPtr) - sizeof(ClockFmtScnStorage));
}
/*
*----------------------------------------------------------------------
*
* ClockFmtScnStorageAllocProc --
*
* Allocate space for a hash entry containing format storage together
* with the string key.
*
* Results:
* The return value is a pointer to the created entry.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
ClockFmtScnStorageAllocProc(
TCL_UNUSED(Tcl_HashTable *),/* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
ClockFmtScnStorage *fss;
const char *string = (const char *) keyPtr;
Tcl_HashEntry *hPtr;
unsigned size = strlen(string) + 1;
unsigned allocsize = sizeof(ClockFmtScnStorage) + sizeof(Tcl_HashEntry);
allocsize += size;
if (size > sizeof(hPtr->key)) {
allocsize -= sizeof(hPtr->key);
}
fss = (ClockFmtScnStorage *)Tcl_Alloc(allocsize);
/* initialize */
memset(fss, 0, sizeof(*fss));
hPtr = HashEntry4FmtScn(fss);
memcpy(&hPtr->key.string, string, size);
hPtr->clientData = 0; /* currently unused */
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* ClockFmtScnStorageFreeProc --
*
* Free format storage object and space of given hash entry.
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static void
ClockFmtScnStorageFreeProc(
Tcl_HashEntry *hPtr)
{
ClockFmtScnStorage *fss = FmtScn4HashEntry(hPtr);
if (fss->scnTok != NULL) {
Tcl_Free(fss->scnTok);
fss->scnTok = NULL;
fss->scnTokC = 0;
}
if (fss->fmtTok != NULL) {
Tcl_Free(fss->fmtTok);
fss->fmtTok = NULL;
fss->fmtTokC = 0;
}
Tcl_Free(fss);
}
/*
*----------------------------------------------------------------------
*
* ClockFmtScnStorageDelete --
*
* Delete format storage object.
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static void
ClockFmtScnStorageDelete(
ClockFmtScnStorage *fss)
{
Tcl_HashEntry *hPtr = HashEntry4FmtScn(fss);
/*
* This will delete a hash entry and call "Tcl_Free" for storage self, if
* some additionally handling required, freeEntryProc can be used instead
*/
Tcl_DeleteHashEntry(hPtr);
}
/*
* Type definition of clock-format tcl object type.
*/
static const Tcl_ObjType ClockFmtObjType = {
"clock-format", /* name */
ClockFmtObj_FreeInternalRep, /* freeIntRepProc */
ClockFmtObj_DupInternalRep, /* dupIntRepProc */
ClockFmtObj_UpdateString, /* updateStringProc */
ClockFmtObj_SetFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define ObjClockFmtScn(objPtr) \
(*((ClockFmtScnStorage **)&(objPtr)->internalRep.twoPtrValue.ptr1))
#define ObjLocFmtKey(objPtr) \
(*((Tcl_Obj **)&(objPtr)->internalRep.twoPtrValue.ptr2))
static void
ClockFmtObj_DupInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
ClockFmtScnStorage *fss = ObjClockFmtScn(srcPtr);
if (fss != NULL) {
Tcl_MutexLock(&ClockFmtMutex);
fss->objRefCount++;
Tcl_MutexUnlock(&ClockFmtMutex);
}
ObjClockFmtScn(copyPtr) = fss;
/* regards special case - format not localizable */
if (ObjLocFmtKey(srcPtr) != srcPtr) {
TclInitObjRef(ObjLocFmtKey(copyPtr), ObjLocFmtKey(srcPtr));
} else {
ObjLocFmtKey(copyPtr) = copyPtr;
}
copyPtr->typePtr = &ClockFmtObjType;
/* if no format representation, dup string representation */
if (fss == NULL) {
copyPtr->bytes = (char *)Tcl_Alloc(srcPtr->length + 1);
memcpy(copyPtr->bytes, srcPtr->bytes, srcPtr->length + 1);
copyPtr->length = srcPtr->length;
}
}
static void
ClockFmtObj_FreeInternalRep(
Tcl_Obj *objPtr)
{
ClockFmtScnStorage *fss = ObjClockFmtScn(objPtr);
if (fss != NULL && initialized) {
Tcl_MutexLock(&ClockFmtMutex);
/* decrement object reference count of format/scan storage */
if (--fss->objRefCount <= 0) {
#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
/* don't remove it right now (may be reusable), just add to GC */
ClockFmtScnStorageGC_In(fss);
#else
/* remove storage (format representation) */
ClockFmtScnStorageDelete(fss);
#endif
}
Tcl_MutexUnlock(&ClockFmtMutex);
}
ObjClockFmtScn(objPtr) = NULL;
if (ObjLocFmtKey(objPtr) != objPtr) {
TclUnsetObjRef(ObjLocFmtKey(objPtr));
} else {
ObjLocFmtKey(objPtr) = NULL;
}
objPtr->typePtr = NULL;
}
static int
ClockFmtObj_SetFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
/* validate string representation before free old internal representation */
(void)TclGetString(objPtr);
/* free old internal representation */
TclFreeInternalRep(objPtr);
/* initial state of format object */
ObjClockFmtScn(objPtr) = NULL;
ObjLocFmtKey(objPtr) = NULL;
objPtr->typePtr = &ClockFmtObjType;
return TCL_OK;
}
static void
ClockFmtObj_UpdateString(
Tcl_Obj *objPtr)
{
const char *name = "UNKNOWN";
size_t len;
ClockFmtScnStorage *fss = ObjClockFmtScn(objPtr);
if (fss != NULL) {
Tcl_HashEntry *hPtr = HashEntry4FmtScn(fss);
name = hPtr->key.string;
}
len = strlen(name);
objPtr->length = len++,
objPtr->bytes = (char *)Tcl_AttemptAlloc(len);
if (objPtr->bytes) {
memcpy(objPtr->bytes, name, len);
}
}
/*
*----------------------------------------------------------------------
*
* ClockFrmObjGetLocFmtKey --
*
* Retrieves format key object used to search localized format.
*
* This is normally stored in second pointer of internal representation.
* If format object is not localizable, it is equal the given format
* pointer (special case to fast fallback by not-localizable formats).
*
* Results:
* Returns tcl object with key or format object if not localizable.
*
* Side effects:
* Converts given format object to ClockFmtObjType on demand for caching
* the key inside its internal representation.
*
*----------------------------------------------------------------------
*/
Tcl_Obj*
ClockFrmObjGetLocFmtKey(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_Obj *keyObj;
if (objPtr->typePtr != &ClockFmtObjType) {
if (ClockFmtObj_SetFromAny(interp, objPtr) != TCL_OK) {
return NULL;
}
}
keyObj = ObjLocFmtKey(objPtr);
if (keyObj) {
return keyObj;
}
keyObj = Tcl_ObjPrintf("FMT_%s", TclGetString(objPtr));
TclInitObjRef(ObjLocFmtKey(objPtr), keyObj);
return keyObj;
}
/*
*----------------------------------------------------------------------
*
* FindOrCreateFmtScnStorage --
*
* Retrieves format storage for given string format.
*
* This will find the given format in the global storage hash table
* or create a format storage object on demaind and save the
* reference in the first pointer of internal representation of given
* object.
*
* Results:
* Returns scan/format storage pointer to ClockFmtScnStorage.
*
* Side effects:
* Converts given format object to ClockFmtObjType on demand for caching
* the format storage reference inside its internal representation.
* Increments objRefCount of the ClockFmtScnStorage reference.
*
*----------------------------------------------------------------------
*/
static ClockFmtScnStorage *
FindOrCreateFmtScnStorage(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
const char *strFmt = TclGetString(objPtr);
ClockFmtScnStorage *fss = NULL;
int isNew;
Tcl_HashEntry *hPtr;
Tcl_MutexLock(&ClockFmtMutex);
/* if not yet initialized */
if (!initialized) {
/* initialize hash table */
Tcl_InitCustomHashTable(&FmtScnHashTable, TCL_CUSTOM_TYPE_KEYS,
&ClockFmtScnStorageHashKeyType);
initialized = 1;
}
/* get or create entry (and alocate storage) */
hPtr = Tcl_CreateHashEntry(&FmtScnHashTable, strFmt, &isNew);
if (hPtr != NULL) {
fss = FmtScn4HashEntry(hPtr);
#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
/* unlink if it is currently in GC */
if (isNew == 0 && fss->objRefCount == 0) {
ClockFmtScnStorage_GC_Out(fss);
}
#endif
/* new reference, so increment in lock right now */
fss->objRefCount++;
ObjClockFmtScn(objPtr) = fss;
}
Tcl_MutexUnlock(&ClockFmtMutex);
if (fss == NULL && interp != NULL) {
Tcl_AppendResult(interp, "retrieve clock format failed \"",
strFmt ? strFmt : "", "\"", (char *)NULL);
Tcl_SetErrorCode(interp, "TCL", "EINVAL", (char *)NULL);
}
return fss;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetClockFrmScnFromObj --
*
* Returns a clock format/scan representation of (*objPtr), if possible.
* If something goes wrong, NULL is returned, and if interp is non-NULL,
* an error message is written there.
*
* Results:
* Valid representation of type ClockFmtScnStorage.
*
* Side effects:
* Caches the ClockFmtScnStorage reference as the internal rep of (*objPtr)
* and in global hash table, shared across all threads.
*
*----------------------------------------------------------------------
*/
ClockFmtScnStorage *
Tcl_GetClockFrmScnFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
ClockFmtScnStorage *fss;
if (objPtr->typePtr != &ClockFmtObjType) {
if (ClockFmtObj_SetFromAny(interp, objPtr) != TCL_OK) {
return NULL;
}
}
fss = ObjClockFmtScn(objPtr);
if (fss == NULL) {
fss = FindOrCreateFmtScnStorage(interp, objPtr);
}
return fss;
}
/*
*----------------------------------------------------------------------
*
* ClockLocalizeFormat --
*
* Wrap the format object in options to the localized format,
* corresponding given locale.
*
* This searches localized format in locale catalog, and if not yet
* exists, it executes ::tcl::clock::LocalizeFormat in given interpreter
* and caches its result in the locale catalog.
*
* Results:
* Localized format object.
*
* Side effects:
* Caches the localized format inside locale catalog.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
ClockLocalizeFormat(
ClockFmtScnCmdArgs *opts)
{
ClockClientData *dataPtr = opts->dataPtr;
Tcl_Obj *valObj = NULL, *keyObj;
keyObj = ClockFrmObjGetLocFmtKey(opts->interp, opts->formatObj);
/* special case - format object is not localizable */
if (keyObj == opts->formatObj) {
return opts->formatObj;
}
/* prevents loss of key object if the format object (where key stored)
* becomes changed (loses its internal representation during evals) */
Tcl_IncrRefCount(keyObj);
if (opts->mcDictObj == NULL) {
ClockMCDict(opts);
if (opts->mcDictObj == NULL) {
goto done;
}
}
/* try to find in cache within locale mc-catalog */
if (Tcl_DictObjGet(NULL, opts->mcDictObj, keyObj, &valObj) != TCL_OK) {
goto done;
}
/* call LocalizeFormat locale format fmtkey */
if (valObj == NULL) {
Tcl_Obj *callargs[4];
callargs[0] = dataPtr->literals[LIT_LOCALIZE_FORMAT];
callargs[1] = opts->localeObj;
callargs[2] = opts->formatObj;
callargs[3] = opts->mcDictObj;
if (Tcl_EvalObjv(opts->interp, 4, callargs, 0) == TCL_OK) {
valObj = Tcl_GetObjResult(opts->interp);
}
/* ensure mcDictObj remains unshared */
if (opts->mcDictObj->refCount > 1) {
/* smart reference (shared dict as object with no ref-counter) */
opts->mcDictObj = TclDictObjSmartRef(opts->interp,
opts->mcDictObj);
}
if (!valObj) {
goto done;
}
/* cache it inside mc-dictionary (this incr. ref count of keyObj/valObj) */
if (Tcl_DictObjPut(opts->interp, opts->mcDictObj, keyObj, valObj) != TCL_OK) {
valObj = NULL;
goto done;
}
Tcl_ResetResult(opts->interp);
/* check special case - format object is not localizable */
if (valObj == opts->formatObj) {
/* mark it as unlocalizable, by setting self as key (without refcount incr) */
if (valObj->typePtr == &ClockFmtObjType) {
TclUnsetObjRef(ObjLocFmtKey(valObj));
ObjLocFmtKey(valObj) = valObj;
}
}
}
done:
TclUnsetObjRef(keyObj);
return (opts->formatObj = valObj);
}
/*
*----------------------------------------------------------------------
*
* FindTokenBegin --
*
* Find begin of given scan token in string, corresponding token type.
*
* Results:
* Position of token inside string if found. Otherwise - end of string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char *
FindTokenBegin(
const char *p,
const char *end,
ClockScanToken *tok,
int flags)
{
if (p < end) {
char c;
/* next token a known token type */
switch (tok->map->type) {
case CTOKT_INT:
case CTOKT_WIDE:
if (!(flags & CLF_STRICT)) {
/* should match at least one digit or space */
while (!isdigit(UCHAR(*p)) && !isspace(UCHAR(*p)) &&
(p = Tcl_UtfNext(p)) < end) {}
} else {
/* should match at least one digit */
while (!isdigit(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {}
}
return p;
case CTOKT_WORD:
c = *(tok->tokWord.start);
goto findChar;
case CTOKT_SPACE:
while (!isspace(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {}
return p;
case CTOKT_CHAR:
c = *((char *)tok->map->data);
findChar:
if (!(flags & CLF_STRICT)) {
/* should match the char or space */
while (*p != c && !isspace(UCHAR(*p)) &&
(p = Tcl_UtfNext(p)) < end) {}
} else {
/* should match the char */
while (*p != c && (p = Tcl_UtfNext(p)) < end) {}
}
return p;
}
}
return p;
}
/*
*----------------------------------------------------------------------
*
* DetermineGreedySearchLen --
*
* Determine min/max lengths as exact as possible (speed, greedy match).
*
* Results:
* None. Lengths are stored in *minLenPtr, *maxLenPtr.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
DetermineGreedySearchLen(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok,
int *minLenPtr,
int *maxLenPtr)
{
int minLen = tok->map->minSize;
int maxLen;
const char *p = yyInput + minLen;
const char *end = info->dateEnd;
/* if still tokens available, try to correct minimum length */
if ((tok + 1)->map) {
end -= tok->endDistance + yySpaceCount;
/* find position of next known token */
p = FindTokenBegin(p, end, tok + 1,
TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT);
if (p < end) {
minLen = p - yyInput;
}
}
/* max length to the end regarding distance to end (min-width of following tokens) */
maxLen = end - yyInput;
/* several amendments */
if (maxLen > tok->map->maxSize) {
maxLen = tok->map->maxSize;
}
if (minLen < tok->map->minSize) {
minLen = tok->map->minSize;
}
if (minLen > maxLen) {
maxLen = minLen;
}
if (maxLen > info->dateEnd - yyInput) {
maxLen = info->dateEnd - yyInput;
}
/* check digits rigth now */
if (tok->map->type == CTOKT_INT || tok->map->type == CTOKT_WIDE) {
p = yyInput;
end = p + maxLen;
if (end > info->dateEnd) {
end = info->dateEnd;
}
while (isdigit(UCHAR(*p)) && p < end) {
p++;
}
maxLen = p - yyInput;
}
/* try to get max length more precise for greedy match,
* check the next ahead token available there */
if (minLen < maxLen && tok->lookAhTok) {
ClockScanToken *laTok = tok + tok->lookAhTok + 1;
p = yyInput + maxLen;
/* regards all possible spaces here (because they are optional) */
end = p + tok->lookAhMax + yySpaceCount + 1;
if (end > info->dateEnd) {
end = info->dateEnd;
}
p += tok->lookAhMin;
if (laTok->map && p < end) {
/* try to find laTok between [lookAhMin, lookAhMax] */
while (minLen < maxLen) {
const char *f = FindTokenBegin(p, end, laTok,
TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT);
/* if found (not below lookAhMax) */
if (f < end) {
break;
}
/* try again with fewer length */
maxLen--;
p--;
end--;
}
} else if (p > end) {
maxLen -= (p - end);
if (maxLen < minLen) {
maxLen = minLen;
}
}
}
*minLenPtr = minLen;
*maxLenPtr = maxLen;
}
/*
*----------------------------------------------------------------------
*
* ObjListSearch --
*
* Find largest part of the input string from start regarding min and
* max lengths in the given list (utf-8, case sensitive).
*
* Results:
* TCL_OK - match found, TCL_RETURN - not matched, TCL_ERROR in error case.
*
* Side effects:
* Input points to end of the found token in string.
*
*----------------------------------------------------------------------
*/
static inline int
ObjListSearch(
DateInfo *info,
int *val,
Tcl_Obj **lstv,
Tcl_Size lstc,
int minLen,
int maxLen)
{
Tcl_Size i, l, lf = -1;
const char *s, *f, *sf;
/* search in list */
for (i = 0; i < lstc; i++) {
s = TclGetStringFromObj(lstv[i], &l);
if (l >= minLen
&& (f = TclUtfFindEqualNC(yyInput, yyInput + maxLen, s, s + l, &sf)) > yyInput) {
l = f - yyInput;
if (l < minLen) {
continue;
}
/* found, try to find longest value (greedy search) */
if (l < maxLen && minLen != maxLen) {
lf = i;
minLen = l + 1;
continue;
}
/* max possible - end of search */
*val = i;
yyInput += l;
break;
}
}
/* if found */
if (i < lstc) {
return TCL_OK;
}
if (lf >= 0) {
*val = lf;
yyInput += minLen - 1;
return TCL_OK;
}
return TCL_RETURN;
}
#if 0
/* currently unused */
static int
LocaleListSearch(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
int mcKey,
int *val,
int minLen,
int maxLen)
{
Tcl_Obj **lstv;
Tcl_Size lstc;
Tcl_Obj *valObj;
/* get msgcat value */
valObj = ClockMCGet(opts, mcKey);
if (valObj == NULL) {
return TCL_ERROR;
}
/* is a list */
if (TclListObjGetElements(opts->interp, valObj, &lstc, &lstv) != TCL_OK) {
return TCL_ERROR;
}
/* search in list */
return ObjListSearch(info, val, lstv, lstc,
minLen, maxLen);
}
#endif
/*
*----------------------------------------------------------------------
*
* ClockMCGetListIdxTree --
*
* Retrieves localized string indexed tree in the locale catalog for
* given literal index mcKey (and builds it on demand).
*
* Searches localized index in locale catalog, and if not yet exists,
* creates string indexed tree and stores it in the locale catalog.
*
* Results:
* Localized string index tree.
*
* Side effects:
* Caches the localized string index tree inside locale catalog.
*
*----------------------------------------------------------------------
*/
static TclStrIdxTree *
ClockMCGetListIdxTree(
ClockFmtScnCmdArgs *opts,
int mcKey)
{
TclStrIdxTree *idxTree;
Tcl_Obj *objPtr = ClockMCGetIdx(opts, mcKey);
if (objPtr != NULL
&& (idxTree = TclStrIdxTreeGetFromObj(objPtr)) != NULL) {
return idxTree;
} else {
/* build new index */
Tcl_Obj **lstv;
Tcl_Size lstc;
Tcl_Obj *valObj;
objPtr = TclStrIdxTreeNewObj();
if ((idxTree = TclStrIdxTreeGetFromObj(objPtr)) == NULL) {
goto done; /* unexpected, but ...*/
}
valObj = ClockMCGet(opts, mcKey);
if (valObj == NULL) {
goto done;
}
if (TclListObjGetElements(opts->interp, valObj, &lstc, &lstv) != TCL_OK) {
goto done;
}
if (TclStrIdxTreeBuildFromList(idxTree, lstc, lstv, NULL) != TCL_OK) {
goto done;
}
ClockMCSetIdx(opts, mcKey, objPtr);
objPtr = NULL;
}
done:
if (objPtr) {
Tcl_DecrRefCount(objPtr);
idxTree = NULL;
}
return idxTree;
}
/*
*----------------------------------------------------------------------
*
* ClockMCGetMultiListIdxTree --
*
* Retrieves localized string indexed tree in the locale catalog for
* multiple lists by literal indices mcKeys (and builds it on demand).
*
* Searches localized index in locale catalog for mcKey, and if not
* yet exists, creates string indexed tree and stores it in the
* locale catalog.
*
* Results:
* Localized string index tree.
*
* Side effects:
* Caches the localized string index tree inside locale catalog.
*
*----------------------------------------------------------------------
*/
static TclStrIdxTree *
ClockMCGetMultiListIdxTree(
ClockFmtScnCmdArgs *opts,
int mcKey,
int *mcKeys)
{
TclStrIdxTree * idxTree;
Tcl_Obj *objPtr = ClockMCGetIdx(opts, mcKey);
if (objPtr != NULL
&& (idxTree = TclStrIdxTreeGetFromObj(objPtr)) != NULL) {
return idxTree;
} else {
/* build new index */
Tcl_Obj **lstv;
Tcl_Size lstc;
Tcl_Obj *valObj;
objPtr = TclStrIdxTreeNewObj();
if ((idxTree = TclStrIdxTreeGetFromObj(objPtr)) == NULL) {
goto done; /* unexpected, but ...*/
}
while (*mcKeys) {
valObj = ClockMCGet(opts, *mcKeys);
if (valObj == NULL) {
goto done;
}
if (TclListObjGetElements(opts->interp, valObj, &lstc, &lstv) != TCL_OK) {
goto done;
}
if (TclStrIdxTreeBuildFromList(idxTree, lstc, lstv, NULL) != TCL_OK) {
goto done;
}
mcKeys++;
}
ClockMCSetIdx(opts, mcKey, objPtr);
objPtr = NULL;
}
done:
if (objPtr) {
Tcl_DecrRefCount(objPtr);
idxTree = NULL;
}
return idxTree;
}
/*
*----------------------------------------------------------------------
*
* ClockStrIdxTreeSearch --
*
* Find largest part of the input string from start regarding lengths
* in the given localized string indexed tree (utf-8, case sensitive).
*
* Results:
* TCL_OK - match found and the index stored in *val,
* TCL_RETURN - not matched or ambigous,
* TCL_ERROR - in error case.
*
* Side effects:
* Input points to end of the found token in string.
*
*----------------------------------------------------------------------
*/
static inline int
ClockStrIdxTreeSearch(
DateInfo *info,
TclStrIdxTree *idxTree,
int *val,
int minLen,
int maxLen)
{
TclStrIdx *foundItem;
const char *f = TclStrIdxTreeSearch(NULL, &foundItem, idxTree,
yyInput, yyInput + maxLen);
if (f <= yyInput || (f - yyInput) < minLen) {
/* not found */
return TCL_RETURN;
}
if (!foundItem->value) {
/* ambigous */
return TCL_RETURN;
}
*val = PTR2INT(foundItem->value);
/* shift input pointer */
yyInput = f;
return TCL_OK;
}
#if 0
/* currently unused */
static int
StaticListSearch(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
const char **lst,
int *val)
{
size_t len;
const char **s = lst;
while (*s != NULL) {
len = strlen(*s);
if (len <= info->dateEnd - yyInput
&& strncasecmp(yyInput, *s, len) == 0) {
*val = (s - lst);
yyInput += len;
break;
}
s++;
}
if (*s != NULL) {
return TCL_OK;
}
return TCL_RETURN;
}
#endif
static inline const char *
FindWordEnd(
ClockScanToken *tok,
const char *p,
const char *end)
{
const char *x = tok->tokWord.start;
const char *pfnd = p;
if (x == tok->tokWord.end - 1) { /* fast phase-out for single char word */
if (*p == *x) {
return ++p;
}
}
/* multi-char word */
x = TclUtfFindEqualNC(x, tok->tokWord.end, p, end, &pfnd);
if (x < tok->tokWord.end) {
/* no match -> error */
return NULL;
}
return pfnd;
}
static int
ClockScnToken_Month_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
#if 0
/* currently unused, test purposes only */
static const char * months[] = {
/* full */
"January", "February", "March",
"April", "May", "June",
"July", "August", "September",
"October", "November", "December",
/* abbr */
"Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec",
NULL
};
int val;
if (StaticListSearch(opts, info, months, &val) != TCL_OK) {
return TCL_RETURN;
}
yyMonth = (val % 12) + 1;
#else
static int monthsKeys[] = {MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, 0};
int ret, val;
int minLen, maxLen;
TclStrIdxTree *idxTree;
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
/* get or create tree in msgcat dict */
idxTree = ClockMCGetMultiListIdxTree(opts, MCLIT_MONTHS_COMB, monthsKeys);
if (idxTree == NULL) {
return TCL_ERROR;
}
ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
if (ret != TCL_OK) {
return ret;
}
yyMonth = val;
#endif
return TCL_OK;
}
static int
ClockScnToken_DayOfWeek_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
static int dowKeys[] = {MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_FULL, 0};
int ret, val;
int minLen, maxLen;
char curTok = *tok->tokWord.start;
TclStrIdxTree *idxTree;
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
/* %u %w %Ou %Ow */
if (curTok != 'a' && curTok != 'A'
&& ((minLen <= 1 && maxLen >= 1) || PTR2INT(tok->map->data))) {
val = -1;
if (PTR2INT(tok->map->data) == 0) {
if (*yyInput >= '0' && *yyInput <= '9') {
val = *yyInput - '0';
}
} else {
idxTree = ClockMCGetListIdxTree(opts, PTR2INT(tok->map->data) /* mcKey */);
if (idxTree == NULL) {
return TCL_ERROR;
}
ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
if (ret != TCL_OK) {
return ret;
}
--val;
}
if (val == -1) {
return TCL_RETURN;
}
if (val == 0) {
val = 7;
}
if (val > 7) {
Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
"day of week is greater than 7", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(opts->interp, "CLOCK", "badDayOfWeek", (char *)NULL);
return TCL_ERROR;
}
info->date.dayOfWeek = val;
yyInput++;
return TCL_OK;
}
/* %a %A */
idxTree = ClockMCGetMultiListIdxTree(opts, MCLIT_DAYS_OF_WEEK_COMB, dowKeys);
if (idxTree == NULL) {
return TCL_ERROR;
}
ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
if (ret != TCL_OK) {
return ret;
}
--val;
if (val == 0) {
val = 7;
}
info->date.dayOfWeek = val;
return TCL_OK;
}
static int
ClockScnToken_amPmInd_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
int ret, val;
int minLen, maxLen;
Tcl_Obj *amPmObj[2];
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
amPmObj[0] = ClockMCGet(opts, MCLIT_AM);
amPmObj[1] = ClockMCGet(opts, MCLIT_PM);
if (amPmObj[0] == NULL || amPmObj[1] == NULL) {
return TCL_ERROR;
}
ret = ObjListSearch(info, &val, amPmObj, 2, minLen, maxLen);
if (ret != TCL_OK) {
return ret;
}
if (val == 0) {
yyMeridian = MERam;
} else {
yyMeridian = MERpm;
}
return TCL_OK;
}
static int
ClockScnToken_LocaleERA_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
ClockClientData *dataPtr = opts->dataPtr;
int ret, val;
int minLen, maxLen;
Tcl_Obj *eraObj[6];
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
eraObj[0] = ClockMCGet(opts, MCLIT_BCE);
eraObj[1] = ClockMCGet(opts, MCLIT_CE);
eraObj[2] = dataPtr->mcLiterals[MCLIT_BCE2];
eraObj[3] = dataPtr->mcLiterals[MCLIT_CE2];
eraObj[4] = dataPtr->mcLiterals[MCLIT_BCE3];
eraObj[5] = dataPtr->mcLiterals[MCLIT_CE3];
if (eraObj[0] == NULL || eraObj[1] == NULL) {
return TCL_ERROR;
}
ret = ObjListSearch(info, &val, eraObj, 6, minLen, maxLen);
if (ret != TCL_OK) {
return ret;
}
if (val & 1) {
yydate.isBce = 0;
} else {
yydate.isBce = 1;
}
return TCL_OK;
}
static int
ClockScnToken_LocaleListMatcher_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
int ret, val;
int minLen, maxLen;
TclStrIdxTree *idxTree;
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
/* get or create tree in msgcat dict */
idxTree = ClockMCGetListIdxTree(opts, PTR2INT(tok->map->data) /* mcKey */);
if (idxTree == NULL) {
return TCL_ERROR;
}
ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
if (ret != TCL_OK) {
return ret;
}
if (tok->map->offs > 0) {
*IntFieldAt(info, tok->map->offs) = --val;
}
return TCL_OK;
}
static int
ClockScnToken_JDN_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
int minLen, maxLen;
const char *p = yyInput, *end, *s;
Tcl_WideInt intJD;
int fractJD = 0, fractJDDiv = 1;
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
end = yyInput + maxLen;
/* currently positive astronomic dates only */
if (*p == '+' || *p == '-') {
p++;
}
s = p;
while (p < end && isdigit(UCHAR(*p))) {
p++;
}
if (Clock_str2wideInt(&intJD, s, p, (*yyInput != '-' ? 1 : -1)) != TCL_OK) {
return TCL_RETURN;
}
yyInput = p;
if (p >= end || *p++ != '.') { /* allow pure integer JDN */
/* by astronomical JD the seconds of day offs is 12 hours */
if (tok->map->offs) {
goto done;
}
/* calendar JD */
yydate.julianDay = intJD;
return TCL_OK;
}
s = p;
while (p < end && isdigit(UCHAR(*p))) {
fractJDDiv *= 10;
p++;
}
if (Clock_str2int(&fractJD, s, p, 1) != TCL_OK) {
return TCL_RETURN;
}
yyInput = p;
done:
/*
* Build a date from julian day (integer and fraction).
* Note, astronomical JDN starts at noon in opposite to calendar julianday.
*/
fractJD = (int)tok->map->offs /* 0 for calendar or 43200 for astro JD */
+ (int)((Tcl_WideInt)SECONDS_PER_DAY * fractJD / fractJDDiv);
if (fractJD >= SECONDS_PER_DAY) {
fractJD %= SECONDS_PER_DAY;
intJD += 1;
}
yydate.secondOfDay = fractJD;
yydate.julianDay = intJD;
yydate.seconds =
-210866803200LL
+ (SECONDS_PER_DAY * intJD)
+ fractJD;
info->flags |= CLF_POSIXSEC;
return TCL_OK;
}
static int
ClockScnToken_TimeZone_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
int minLen, maxLen;
int len = 0;
const char *p = yyInput;
Tcl_Obj *tzObjStor = NULL;
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
/* numeric timezone */
if (*p == '+' || *p == '-') {
/* max chars in numeric zone = "+00:00:00" */
#define MAX_ZONE_LEN 9
char buf[MAX_ZONE_LEN + 1];
char *bp = buf;
*bp++ = *p++;
len++;
if (maxLen > MAX_ZONE_LEN) {
maxLen = MAX_ZONE_LEN;
}
/* cumulate zone into buf without ':' */
while (len + 1 < maxLen) {
if (!isdigit(UCHAR(*p))) {
break;
}
*bp++ = *p++;
len++;
if (!isdigit(UCHAR(*p))) {
break;
}
*bp++ = *p++;
len++;
if (len + 2 < maxLen) {
if (*p == ':') {
p++;
len++;
}
}
}
*bp = '\0';
if (len < minLen) {
return TCL_RETURN;
}
#undef MAX_ZONE_LEN
/* timezone */
tzObjStor = Tcl_NewStringObj(buf, bp - buf);
} else {
/* legacy (alnum) timezone like CEST, etc. */
if (maxLen > 4) {
maxLen = 4;
}
while (len < maxLen) {
if ((*p & 0x80)
|| (!isalpha(UCHAR(*p)) && !isdigit(UCHAR(*p)))) { /* INTL: ISO only. */
break;
}
p++;
len++;
}
if (len < minLen) {
return TCL_RETURN;
}
/* timezone */
tzObjStor = Tcl_NewStringObj(yyInput, p - yyInput);
/* convert using dict */
}
/* try to apply new time zone */
Tcl_IncrRefCount(tzObjStor);
opts->timezoneObj = ClockSetupTimeZone(opts->dataPtr, opts->interp,
tzObjStor);
Tcl_DecrRefCount(tzObjStor);
if (opts->timezoneObj == NULL) {
return TCL_ERROR;
}
yyInput += len;
return TCL_OK;
}
static int
ClockScnToken_StarDate_Proc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok)
{
int minLen, maxLen;
const char *p = yyInput, *end, *s;
int year, fractYear, fractDayDiv, fractDay;
static const char *stardatePref = "stardate ";
DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
end = yyInput + maxLen;
/* stardate string */
p = TclUtfFindEqualNCInLwr(p, end, stardatePref, stardatePref + 9, &s);
if (p >= end || p - yyInput < 9) {
return TCL_RETURN;
}
/* bypass spaces */
while (p < end && isspace(UCHAR(*p))) {
p++;
}
if (p >= end) {
return TCL_RETURN;
}
/* currently positive stardate only */
if (*p == '+') {
p++;
}
s = p;
while (p < end && isdigit(UCHAR(*p))) {
p++;
}
if (p >= end || p - s < 4) {
return TCL_RETURN;
}
if (Clock_str2int(&year, s, p - 3, 1) != TCL_OK
|| Clock_str2int(&fractYear, p - 3, p, 1) != TCL_OK) {
return TCL_RETURN;
}
if (*p++ != '.') {
return TCL_RETURN;
}
s = p;
fractDayDiv = 1;
while (p < end && isdigit(UCHAR(*p))) {
fractDayDiv *= 10;
p++;
}
if (Clock_str2int(&fractDay, s, p, 1) != TCL_OK) {
return TCL_RETURN;
}
yyInput = p;
/* Build a date from year and fraction. */
yydate.year = year + RODDENBERRY;
yydate.isBce = 0;
yydate.gregorian = 1;
if (IsGregorianLeapYear(&yydate)) {
fractYear *= 366;
} else {
fractYear *= 365;
}
yydate.dayOfYear = fractYear / 1000 + 1;
if (fractYear % 1000 >= 500) {
yydate.dayOfYear++;
}
GetJulianDayFromEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
yydate.localSeconds =
-210866803200LL
+ (SECONDS_PER_DAY * yydate.julianDay)
+ (SECONDS_PER_DAY * fractDay / fractDayDiv);
return TCL_OK;
}
/*
* Descriptors for the various fields in [clock scan].
*/
static const char *ScnSTokenMapIndex = "dmbyYHMSpJjCgGVazUsntQ";
static const ClockScanTokenMap ScnSTokenMap[] = {
/* %d %e */
{CTOKT_INT, CLF_DAYOFMONTH, 0, 1, 2, offsetof(DateInfo, date.dayOfMonth),
NULL, NULL},
/* %m %N */
{CTOKT_INT, CLF_MONTH, 0, 1, 2, offsetof(DateInfo, date.month),
NULL, NULL},
/* %b %B %h */
{CTOKT_PARSER, CLF_MONTH, 0, 0, 0xffff, 0,
ClockScnToken_Month_Proc, NULL},
/* %y */
{CTOKT_INT, CLF_YEAR, 0, 1, 2, offsetof(DateInfo, date.year),
NULL, NULL},
/* %Y */
{CTOKT_INT, CLF_YEAR | CLF_CENTURY, 0, 4, 4, offsetof(DateInfo, date.year),
NULL, NULL},
/* %H %k %I %l */
{CTOKT_INT, CLF_TIME, 0, 1, 2, offsetof(DateInfo, date.hour),
NULL, NULL},
/* %M */
{CTOKT_INT, CLF_TIME, 0, 1, 2, offsetof(DateInfo, date.minutes),
NULL, NULL},
/* %S */
{CTOKT_INT, CLF_TIME, 0, 1, 2, offsetof(DateInfo, date.secondOfMin),
NULL, NULL},
/* %p %P */
{CTOKT_PARSER, 0, 0, 0, 0xffff, 0,
ClockScnToken_amPmInd_Proc, NULL},
/* %J */
{CTOKT_WIDE, CLF_JULIANDAY | CLF_SIGNED, 0, 1, 0xffff, offsetof(DateInfo, date.julianDay),
NULL, NULL},
/* %j */
{CTOKT_INT, CLF_DAYOFYEAR, 0, 1, 3, offsetof(DateInfo, date.dayOfYear),
NULL, NULL},
/* %C */
{CTOKT_INT, CLF_CENTURY|CLF_ISO8601CENTURY, 0, 1, 2, offsetof(DateInfo, dateCentury),
NULL, NULL},
/* %g */
{CTOKT_INT, CLF_ISO8601YEAR, 0, 2, 2, offsetof(DateInfo, date.iso8601Year),
NULL, NULL},
/* %G */
{CTOKT_INT, CLF_ISO8601YEAR | CLF_ISO8601CENTURY, 0, 4, 4, offsetof(DateInfo, date.iso8601Year),
NULL, NULL},
/* %V */
{CTOKT_INT, CLF_ISO8601WEEK, 0, 1, 2, offsetof(DateInfo, date.iso8601Week),
NULL, NULL},
/* %a %A %u %w */
{CTOKT_PARSER, CLF_DAYOFWEEK, 0, 0, 0xffff, 0,
ClockScnToken_DayOfWeek_Proc, NULL},
/* %z %Z */
{CTOKT_PARSER, CLF_OPTIONAL, 0, 0, 0xffff, 0,
ClockScnToken_TimeZone_Proc, NULL},
/* %U %W */
{CTOKT_INT, CLF_OPTIONAL, 0, 1, 2, 0, /* currently no capture, parse only token */
NULL, NULL},
/* %s */
{CTOKT_WIDE, CLF_POSIXSEC | CLF_SIGNED, 0, 1, 0xffff, offsetof(DateInfo, date.seconds),
NULL, NULL},
/* %n */
{CTOKT_CHAR, 0, 0, 1, 1, 0, NULL, "\n"},
/* %t */
{CTOKT_CHAR, 0, 0, 1, 1, 0, NULL, "\t"},
/* %Q */
{CTOKT_PARSER, CLF_LOCALSEC, 0, 16, 30, 0,
ClockScnToken_StarDate_Proc, NULL},
};
static const char *ScnSTokenMapAliasIndex[2] = {
"eNBhkIlPAuwZW",
"dmbbHHHpaaazU"
};
static const char *ScnETokenMapIndex = "EJjys";
static const ClockScanTokenMap ScnETokenMap[] = {
/* %EE */
{CTOKT_PARSER, 0, 0, 0, 0xffff, offsetof(DateInfo, date.year),
ClockScnToken_LocaleERA_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %EJ */
{CTOKT_PARSER, CLF_JULIANDAY | CLF_SIGNED, 0, 1, 0xffff, 0, /* calendar JDN starts at midnight */
ClockScnToken_JDN_Proc, NULL},
/* %Ej */
{CTOKT_PARSER, CLF_JULIANDAY | CLF_SIGNED, 0, 1, 0xffff, (SECONDS_PER_DAY/2), /* astro JDN starts at noon */
ClockScnToken_JDN_Proc, NULL},
/* %Ey */
{CTOKT_PARSER, 0, 0, 0, 0xffff, 0, /* currently no capture, parse only token */
ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %Es */
{CTOKT_WIDE, CLF_LOCALSEC | CLF_SIGNED, 0, 1, 0xffff, offsetof(DateInfo, date.localSeconds),
NULL, NULL},
};
static const char *ScnETokenMapAliasIndex[2] = {
"",
""
};
static const char *ScnOTokenMapIndex = "dmyHMSu";
static const ClockScanTokenMap ScnOTokenMap[] = {
/* %Od %Oe */
{CTOKT_PARSER, CLF_DAYOFMONTH, 0, 0, 0xffff, offsetof(DateInfo, date.dayOfMonth),
ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %Om */
{CTOKT_PARSER, CLF_MONTH, 0, 0, 0xffff, offsetof(DateInfo, date.month),
ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %Oy */
{CTOKT_PARSER, CLF_YEAR, 0, 0, 0xffff, offsetof(DateInfo, date.year),
ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %OH %Ok %OI %Ol */
{CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, offsetof(DateInfo, date.hour),
ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %OM */
{CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, offsetof(DateInfo, date.minutes),
ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %OS */
{CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, offsetof(DateInfo, date.secondOfMin),
ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %Ou Ow */
{CTOKT_PARSER, CLF_DAYOFWEEK, 0, 0, 0xffff, 0,
ClockScnToken_DayOfWeek_Proc, (void *)MCLIT_LOCALE_NUMERALS},
};
static const char *ScnOTokenMapAliasIndex[2] = {
"ekIlw",
"dHHHu"
};
/* Token map reserved for CTOKT_SPACE */
static const ClockScanTokenMap ScnSpaceTokenMap = {
CTOKT_SPACE, 0, 0, 1, 1, 0, NULL, NULL
};
static const ClockScanTokenMap ScnWordTokenMap = {
CTOKT_WORD, 0, 0, 1, 1, 0, NULL, NULL
};
static inline unsigned
EstimateTokenCount(
const char *fmt,
const char *end)
{
const char *p = fmt;
unsigned tokcnt;
/* estimate token count by % char and format length */
tokcnt = 0;
while (p <= end) {
if (*p++ == '%') {
tokcnt++;
p++;
}
}
p = fmt + tokcnt * 2;
if (p < end) {
if ((unsigned)(end - p) < tokcnt) {
tokcnt += (end - p);
} else {
tokcnt += tokcnt;
}
}
return ++tokcnt;
}
#define AllocTokenInChain(tok, chain, tokCnt, type) \
if (++(tok) >= (chain) + (tokCnt)) { \
chain = (type)Tcl_Realloc((char *)(chain), \
(tokCnt + CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE) * sizeof(*(tok))); \
(tok) = (chain) + (tokCnt); \
(tokCnt) += CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE; \
} \
memset(tok, 0, sizeof(*(tok)));
/*
*----------------------------------------------------------------------
*/
ClockFmtScnStorage *
ClockGetOrParseScanFormat(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *formatObj) /* Format container */
{
ClockFmtScnStorage *fss;
fss = Tcl_GetClockFrmScnFromObj(interp, formatObj);
if (fss == NULL) {
return NULL;
}
/* if format (scnTok) already tokenized */
if (fss->scnTok != NULL) {
return fss;
}
Tcl_MutexLock(&ClockFmtMutex);
/* first time scanning - tokenize format */
if (fss->scnTok == NULL) {
ClockScanToken *tok, *scnTok;
unsigned tokCnt;
const char *p, *e, *cp;
e = p = HashEntry4FmtScn(fss)->key.string;
e += strlen(p);
/* estimate token count by % char and format length */
fss->scnTokC = EstimateTokenCount(p, e);
fss->scnSpaceCount = 0;
scnTok = tok = (ClockScanToken *)Tcl_Alloc(sizeof(*tok) * fss->scnTokC);
memset(tok, 0, sizeof(*tok));
tokCnt = 1;
while (p < e) {
switch (*p) {
case '%': {
const ClockScanTokenMap *scnMap = ScnSTokenMap;
const char *mapIndex = ScnSTokenMapIndex;
const char **aliasIndex = ScnSTokenMapAliasIndex;
if (p + 1 >= e) {
goto word_tok;
}
p++;
/* try to find modifier: */
switch (*p) {
case '%':
/* begin new word token - don't join with previous word token,
* because current mapping should be "...%%..." -> "...%..." */
tok->map = &ScnWordTokenMap;
tok->tokWord.start = p;
tok->tokWord.end = p + 1;
AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
tokCnt++;
p++;
continue;
case 'E':
scnMap = ScnETokenMap,
mapIndex = ScnETokenMapIndex,
aliasIndex = ScnETokenMapAliasIndex;
p++;
break;
case 'O':
scnMap = ScnOTokenMap,
mapIndex = ScnOTokenMapIndex,
aliasIndex = ScnOTokenMapAliasIndex;
p++;
break;
}
/* search direct index */
cp = strchr(mapIndex, *p);
if (!cp || *cp == '\0') {
/* search wrapper index (multiple chars for same token) */
cp = strchr(aliasIndex[0], *p);
if (!cp || *cp == '\0') {
p--;
if (scnMap != ScnSTokenMap) {
p--;
}
goto word_tok;
}
cp = strchr(mapIndex, aliasIndex[1][cp - aliasIndex[0]]);
if (!cp || *cp == '\0') { /* unexpected, but ... */
#ifdef DEBUG
Tcl_Panic("token \"%c\" has no map in wrapper resolver", *p);
#endif
p--;
if (scnMap != ScnSTokenMap) {
p--;
}
goto word_tok;
}
}
tok->map = &scnMap[cp - mapIndex];
tok->tokWord.start = p;
/* calculate look ahead value by standing together tokens */
if (tok > scnTok) {
ClockScanToken *prevTok = tok - 1;
while (prevTok >= scnTok) {
if (prevTok->map->type != tok->map->type) {
break;
}
prevTok->lookAhMin += tok->map->minSize;
prevTok->lookAhMax += tok->map->maxSize;
prevTok->lookAhTok++;
prevTok--;
}
}
/* increase space count used in format */
if (tok->map->type == CTOKT_CHAR
&& isspace(UCHAR(*((char *)tok->map->data)))) {
fss->scnSpaceCount++;
}
/* next token */
AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
tokCnt++;
p++;
continue;
}
default:
if (isspace(UCHAR(*p))) {
tok->map = &ScnSpaceTokenMap;
tok->tokWord.start = p++;
while (p < e && isspace(UCHAR(*p))) {
p++;
}
tok->tokWord.end = p;
/* increase space count used in format */
fss->scnSpaceCount++;
/* next token */
AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
tokCnt++;
continue;
}
word_tok:
{
/* try continue with previous word token */
ClockScanToken *wordTok = tok - 1;
if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) {
/* start with new word token */
wordTok = tok;
wordTok->tokWord.start = p;
wordTok->map = &ScnWordTokenMap;
}
do {
if (isspace(UCHAR(*p))) {
fss->scnSpaceCount++;
}
p = Tcl_UtfNext(p);
} while (p < e && *p != '%');
wordTok->tokWord.end = p;
if (wordTok == tok) {
AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
tokCnt++;
}
}
break;
}
}
/* calculate end distance value for each tokens */
if (tok > scnTok) {
unsigned endDist = 0;
ClockScanToken *prevTok = tok - 1;
while (prevTok >= scnTok) {
prevTok->endDistance = endDist;
if (prevTok->map->type != CTOKT_WORD) {
endDist += prevTok->map->minSize;
} else {
endDist += prevTok->tokWord.end - prevTok->tokWord.start;
}
prevTok--;
}
}
/* correct count of real used tokens and free mem if desired
* (1 is acceptable delta to prevent memory fragmentation) */
if (fss->scnTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) {
if ((tok = (ClockScanToken *)
Tcl_AttemptRealloc(scnTok, tokCnt * sizeof(*tok))) != NULL) {
scnTok = tok;
}
}
/* now we're ready - assign now to storage (note the threaded race condition) */
fss->scnTok = scnTok;
fss->scnTokC = tokCnt;
}
Tcl_MutexUnlock(&ClockFmtMutex);
return fss;
}
/*
*----------------------------------------------------------------------
*/
int
ClockScan(
DateInfo *info, /* Date fields used for parsing & converting */
Tcl_Obj *strObj, /* String containing the time to scan */
ClockFmtScnCmdArgs *opts) /* Command options */
{
ClockClientData *dataPtr = opts->dataPtr;
ClockFmtScnStorage *fss;
ClockScanToken *tok;
const ClockScanTokenMap *map;
const char *p, *x, *end;
unsigned short flags = 0;
int ret = TCL_ERROR;
/* get localized format */
if (ClockLocalizeFormat(opts) == NULL) {
return TCL_ERROR;
}
if (!(fss = ClockGetOrParseScanFormat(opts->interp, opts->formatObj))
|| !(tok = fss->scnTok)) {
return TCL_ERROR;
}
/* prepare parsing */
yyMeridian = MER24;
p = TclGetString(strObj);
end = p + strObj->length;
/* in strict mode - bypass spaces at begin / end only (not between tokens) */
if (opts->flags & CLF_STRICT) {
while (p < end && isspace(UCHAR(*p))) {
p++;
}
}
yyInput = p;
/* look ahead to count spaces (bypass it by count length and distances) */
x = end;
while (p < end) {
if (isspace(UCHAR(*p))) {
x = ++p; /* after first space in space block */
yySpaceCount++;
while (p < end && isspace(UCHAR(*p))) {
p++;
yySpaceCount++;
}
continue;
}
x = end;
p++;
}
/* ignore more as 1 space at end */
yySpaceCount -= (end - x);
end = x;
/* ignore mandatory spaces used in format */
yySpaceCount -= fss->scnSpaceCount;
if (yySpaceCount < 0) {
yySpaceCount = 0;
}
info->dateStart = p = yyInput;
info->dateEnd = end;
/* parse string */
for (; tok->map != NULL; tok++) {
map = tok->map;
/* bypass spaces at begin of input before parsing each token */
if (!(opts->flags & CLF_STRICT)
&& (map->type != CTOKT_SPACE
&& map->type != CTOKT_WORD
&& map->type != CTOKT_CHAR)) {
while (p < end && isspace(UCHAR(*p))) {
yySpaceCount--;
p++;
}
}
yyInput = p;
/* end of input string */
if (p >= end) {
break;
}
switch (map->type) {
case CTOKT_INT:
case CTOKT_WIDE: {
int minLen, size;
int sign = 1;
if (map->flags & CLF_SIGNED) {
if (*p == '+') {
yyInput = ++p;
} else if (*p == '-') {
yyInput = ++p;
sign = -1;
}
}
DetermineGreedySearchLen(opts, info, tok, &minLen, &size);
if (size < map->minSize) {
/* missing input -> error */
if ((map->flags & CLF_OPTIONAL)) {
continue;
}
goto not_match;
}
/* string 2 number, put number into info structure by offset */
if (map->offs) {
p = yyInput;
x = p + size;
if (map->type == CTOKT_INT) {
if (size <= 10) {
Clock_str2int_no(IntFieldAt(info, map->offs),
p, x, sign);
} else if (Clock_str2int(
IntFieldAt(info, map->offs), p, x, sign) != TCL_OK) {
goto overflow;
}
p = x;
} else {
if (size <= 18) {
Clock_str2wideInt_no(
WideFieldAt(info, map->offs), p, x, sign);
} else if (Clock_str2wideInt(
WideFieldAt(info, map->offs), p, x, sign) != TCL_OK) {
goto overflow;
}
p = x;
}
flags = (flags & ~map->clearFlags) | map->flags;
}
break;
}
case CTOKT_PARSER:
switch (map->parser(opts, info, tok)) {
case TCL_OK:
break;
case TCL_RETURN:
if ((map->flags & CLF_OPTIONAL)) {
yyInput = p;
continue;
}
goto not_match;
default:
goto done;
}
/* decrement count for possible spaces in match */
while (p < yyInput) {
if (isspace(UCHAR(*p))) {
yySpaceCount--;
}
p++;
}
p = yyInput;
flags = (flags & ~map->clearFlags) | map->flags;
break;
case CTOKT_SPACE:
/* at least one space */
if (!isspace(UCHAR(*p))) {
/* unmatched -> error */
goto not_match;
}
/* don't decrement yySpaceCount by regular (first expected space),
* already considered above with fss->scnSpaceCount */;
p++;
while (p < end && isspace(UCHAR(*p))) {
yySpaceCount--;
p++;
}
break;
case CTOKT_WORD:
x = FindWordEnd(tok, p, end);
if (!x) {
/* no match -> error */
goto not_match;
}
p = x;
break;
case CTOKT_CHAR:
x = (char *)map->data;
if (*x != *p) {
/* no match -> error */
goto not_match;
}
if (isspace(UCHAR(*x))) {
yySpaceCount--;
}
p++;
break;
}
}
/* check end was reached */
if (p < end) {
/* in non-strict mode bypass spaces at end of input */
if (!(opts->flags & CLF_STRICT) && isspace(UCHAR(*p))) {
p++;
while (p < end && isspace(UCHAR(*p))) {
p++;
}
}
/* something after last token - wrong format */
if (p < end) {
goto not_match;
}
}
/* end of string, check only optional tokens at end, otherwise - not match */
while (tok->map != NULL) {
if (!(opts->flags & CLF_STRICT) && (tok->map->type == CTOKT_SPACE)) {
tok++;
if (tok->map == NULL) {
/* no tokens anymore - trailing spaces are mandatory */
goto not_match;
}
}
if (!(tok->map->flags & CLF_OPTIONAL)) {
goto not_match;
}
tok++;
}
/*
* Invalidate result
*/
flags |= info->flags;
/* seconds token (%s) take precedence over all other tokens */
if ((opts->flags & CLF_EXTENDED) || !(flags & CLF_POSIXSEC)) {
if (flags & CLF_DATE) {
if (!(flags & CLF_JULIANDAY)) {
info->flags |= CLF_ASSEMBLE_SECONDS|CLF_ASSEMBLE_JULIANDAY;
/* dd precedence below ddd */
switch (flags & (CLF_MONTH|CLF_DAYOFYEAR|CLF_DAYOFMONTH)) {
case (CLF_DAYOFYEAR | CLF_DAYOFMONTH):
/* miss month: ddd over dd (without month) */
flags &= ~CLF_DAYOFMONTH;
/* fallthrough */
case CLF_DAYOFYEAR:
/* ddd over naked weekday */
if (!(flags & CLF_ISO8601YEAR)) {
flags &= ~CLF_ISO8601WEEK;
}
break;
case CLF_MONTH | CLF_DAYOFYEAR | CLF_DAYOFMONTH:
/* both available: mmdd over ddd */
case CLF_MONTH | CLF_DAYOFMONTH:
case CLF_DAYOFMONTH:
/* mmdd / dd over naked weekday */
if (!(flags & CLF_ISO8601YEAR)) {
flags &= ~CLF_ISO8601WEEK;
}
break;
/* neither mmdd nor ddd available */
case 0:
/* but we have day of the week, which can be used */
if (flags & CLF_DAYOFWEEK) {
/* prefer week based calculation of julianday */
flags |= CLF_ISO8601WEEK;
}
}
/* YearWeekDay below YearMonthDay */
if ((flags & CLF_ISO8601WEEK)
&& ((flags & (CLF_YEAR | CLF_DAYOFYEAR)) == (CLF_YEAR | CLF_DAYOFYEAR)
|| (flags & (CLF_YEAR | CLF_DAYOFMONTH | CLF_MONTH)) == (
CLF_YEAR | CLF_DAYOFMONTH | CLF_MONTH))) {
/* yy precedence below yyyy */
if (!(flags & CLF_ISO8601CENTURY) && (flags & CLF_CENTURY)) {
/* normally precedence of ISO is higher, but no century - so put it down */
flags &= ~CLF_ISO8601WEEK;
} else if (!(flags & CLF_ISO8601YEAR)) {
/* yymmdd or yyddd over naked weekday */
flags &= ~CLF_ISO8601WEEK;
}
}
if (flags & CLF_YEAR) {
if (yyYear < 100) {
if (!(flags & CLF_CENTURY)) {
if (yyYear >= dataPtr->yearOfCenturySwitch) {
yyYear -= 100;
}
yyYear += dataPtr->currentYearCentury;
} else {
yyYear += info->dateCentury * 100;
}
}
}
if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) {
if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) {
/* for calculations expected iso year */
info->date.iso8601Year = yyYear;
} else if (info->date.iso8601Year < 100) {
if (!(flags & CLF_ISO8601CENTURY)) {
if (info->date.iso8601Year >= dataPtr->yearOfCenturySwitch) {
info->date.iso8601Year -= 100;
}
info->date.iso8601Year += dataPtr->currentYearCentury;
} else {
info->date.iso8601Year += info->dateCentury * 100;
}
}
if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_ISO8601YEAR) {
/* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */
yyYear = info->date.iso8601Year;
}
}
}
}
/* if no time - reset time */
if (!(flags & (CLF_TIME | CLF_LOCALSEC | CLF_POSIXSEC))) {
info->flags |= CLF_ASSEMBLE_SECONDS;
yydate.localSeconds = 0;
}
if (flags & CLF_TIME) {
info->flags |= CLF_ASSEMBLE_SECONDS;
yySecondOfDay = ToSeconds(yyHour, yyMinutes,
yySeconds, yyMeridian);
} else if (!(flags & (CLF_LOCALSEC | CLF_POSIXSEC))) {
info->flags |= CLF_ASSEMBLE_SECONDS;
yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY;
}
}
/* tell caller which flags were set */
info->flags |= flags;
ret = TCL_OK;
done:
return ret;
/* Error case reporting. */
overflow:
Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
"integer value too large to represent", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(opts->interp, "CLOCK", "dateTooLarge", (char *)NULL);
goto done;
not_match:
#if 1
Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
"input string does not match supplied format", TCL_AUTO_LENGTH));
#else
/* to debug where exactly scan breaks */
Tcl_SetObjResult(opts->interp, Tcl_ObjPrintf(
"input string \"%s\" does not match supplied format \"%s\","
" locale \"%s\" - token \"%s\"",
info->dateStart, HashEntry4FmtScn(fss)->key.string,
TclGetString(opts->localeObj),
tok && tok->tokWord.start ? tok->tokWord.start : "NULL"));
#endif
Tcl_SetErrorCode(opts->interp, "CLOCK", "badInputString", (char *)NULL);
goto done;
}
#define FrmResultIsAllocated(dateFmt) \
(dateFmt->resEnd - dateFmt->resMem > MIN_FMT_RESULT_BLOCK_ALLOC)
static inline int
FrmResultAllocate(
DateFormat *dateFmt,
int len)
{
int needed = dateFmt->output + len - dateFmt->resEnd;
if (needed >= 0) { /* >= 0 - regards NTS zero */
int newsize = dateFmt->resEnd - dateFmt->resMem
+ needed + MIN_FMT_RESULT_BLOCK_ALLOC * 2;
char *newRes;
/* differentiate between stack and memory */
if (!FrmResultIsAllocated(dateFmt)) {
newRes = (char *)Tcl_AttemptAlloc(newsize);
if (newRes == NULL) {
return TCL_ERROR;
}
memcpy(newRes, dateFmt->resMem, dateFmt->output - dateFmt->resMem);
} else {
newRes = (char *)Tcl_AttemptRealloc(dateFmt->resMem, newsize);
if (newRes == NULL) {
return TCL_ERROR;
}
}
dateFmt->output = newRes + (dateFmt->output - dateFmt->resMem);
dateFmt->resMem = newRes;
dateFmt->resEnd = newRes + newsize;
}
return TCL_OK;
}
static int
ClockFmtToken_HourAMPM_Proc(
TCL_UNUSED(ClockFmtScnCmdArgs *),
TCL_UNUSED(DateFormat *),
TCL_UNUSED(ClockFormatToken *),
int *val)
{
*val = ((*val + SECONDS_PER_DAY - 3600) / 3600) % 12 + 1;
return TCL_OK;
}
static int
ClockFmtToken_AMPM_Proc(
ClockFmtScnCmdArgs *opts,
DateFormat *dateFmt,
ClockFormatToken *tok,
int *val)
{
Tcl_Obj *mcObj;
const char *s;
Tcl_Size len;
if (*val < (SECONDS_PER_DAY / 2)) {
mcObj = ClockMCGet(opts, MCLIT_AM);
} else {
mcObj = ClockMCGet(opts, MCLIT_PM);
}
if (mcObj == NULL) {
return TCL_ERROR;
}
s = TclGetStringFromObj(mcObj, &len);
if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
return TCL_ERROR;
}
memcpy(dateFmt->output, s, len + 1);
if (*tok->tokWord.start == 'p') {
len = Tcl_UtfToUpper(dateFmt->output);
}
dateFmt->output += len;
return TCL_OK;
}
static int
ClockFmtToken_StarDate_Proc(
TCL_UNUSED(ClockFmtScnCmdArgs *),
DateFormat *dateFmt,
TCL_UNUSED(ClockFormatToken *),
TCL_UNUSED(int *))
{
int fractYear;
/* Get day of year, zero based */
int v = dateFmt->date.dayOfYear - 1;
/* Convert day of year to a fractional year */
if (IsGregorianLeapYear(&dateFmt->date)) {
fractYear = 1000 * v / 366;
} else {
fractYear = 1000 * v / 365;
}
/* Put together the StarDate as "Stardate %02d%03d.%1d" */
if (FrmResultAllocate(dateFmt, 30) != TCL_OK) {
return TCL_ERROR;
}
memcpy(dateFmt->output, "Stardate ", 9);
dateFmt->output += 9;
dateFmt->output = Clock_itoaw(dateFmt->output,
dateFmt->date.year - RODDENBERRY, '0', 2);
dateFmt->output = Clock_itoaw(dateFmt->output,
fractYear, '0', 3);
*dateFmt->output++ = '.';
/* be sure positive after decimal point (note: clock-value can be negative) */
v = dateFmt->date.secondOfDay / (SECONDS_PER_DAY / 10);
if (v < 0) {
v = 10 + v;
}
dateFmt->output = Clock_itoaw(dateFmt->output, v, '0', 1);
return TCL_OK;
}
static int
ClockFmtToken_WeekOfYear_Proc(
TCL_UNUSED(ClockFmtScnCmdArgs *),
DateFormat *dateFmt,
ClockFormatToken *tok,
int *val)
{
int dow = dateFmt->date.dayOfWeek;
if (*tok->tokWord.start == 'U') {
if (dow == 7) {
dow = 0;
}
dow++;
}
*val = (dateFmt->date.dayOfYear - dow + 7) / 7;
return TCL_OK;
}
static int
ClockFmtToken_JDN_Proc(
TCL_UNUSED(ClockFmtScnCmdArgs *),
DateFormat *dateFmt,
ClockFormatToken *tok,
TCL_UNUSED(int *))
{
Tcl_WideInt intJD = dateFmt->date.julianDay;
int fractJD;
/* Convert to JDN parts (regarding start offset) and time fraction */
fractJD = dateFmt->date.secondOfDay
- (int)tok->map->offs; /* 0 for calendar or 43200 for astro JD */
if (fractJD < 0) {
intJD--;
fractJD += SECONDS_PER_DAY;
}
if (fractJD && intJD < 0) { /* avoid jump over 0, by negative JD's */
intJD++;
if (intJD == 0) {
/* -0.0 / -0.9 has zero integer part, so append "-" extra */
if (FrmResultAllocate(dateFmt, 1) != TCL_OK) {
return TCL_ERROR;
}
*dateFmt->output++ = '-';
}
/* and inverse seconds of day, -0(75) -> -0.25 as float */
fractJD = SECONDS_PER_DAY - fractJD;
}
/* 21 is max width of (negative) wide-int (rather smaller, but anyway a time fraction below) */
if (FrmResultAllocate(dateFmt, 21) != TCL_OK) {
return TCL_ERROR;
}
dateFmt->output = Clock_witoaw(dateFmt->output, intJD, '0', 1);
/* simplest cases .0 and .5 */
if (!fractJD || fractJD == (SECONDS_PER_DAY / 2)) {
/* point + 0 or 5 */
if (FrmResultAllocate(dateFmt, 1 + 1) != TCL_OK) {
return TCL_ERROR;
}
*dateFmt->output++ = '.';
*dateFmt->output++ = !fractJD ? '0' : '5';
*dateFmt->output = '\0';
return TCL_OK;
} else {
/* wrap the time fraction */
#define JDN_MAX_PRECISION 8
#define JDN_MAX_PRECBOUND 100000000 /* 10**JDN_MAX_PRECISION */
char *p;
/* to float (part after floating point, + 0.5 to round it up) */
fractJD = (int)(
(double)fractJD * JDN_MAX_PRECBOUND / SECONDS_PER_DAY + 0.5);
/* point + integer (as time fraction after floating point) */
if (FrmResultAllocate(dateFmt, 1 + JDN_MAX_PRECISION) != TCL_OK) {
return TCL_ERROR;
}
*dateFmt->output++ = '.';
p = Clock_itoaw(dateFmt->output, fractJD, '0', JDN_MAX_PRECISION);
/* remove trailing zero's */
dateFmt->output++;
while (p > dateFmt->output && p[-1] == '0') {
p--;
}
*p = '\0';
dateFmt->output = p;
}
return TCL_OK;
}
static int
ClockFmtToken_TimeZone_Proc(
ClockFmtScnCmdArgs *opts,
DateFormat *dateFmt,
ClockFormatToken *tok,
TCL_UNUSED(int *))
{
if (*tok->tokWord.start == 'z') {
int z = dateFmt->date.tzOffset;
char sign = '+';
if (z < 0) {
z = -z;
sign = '-';
}
if (FrmResultAllocate(dateFmt, 7) != TCL_OK) {
return TCL_ERROR;
}
*dateFmt->output++ = sign;
dateFmt->output = Clock_itoaw(dateFmt->output, z / 3600, '0', 2);
z %= 3600;
dateFmt->output = Clock_itoaw(dateFmt->output, z / 60, '0', 2);
z %= 60;
if (z != 0) {
dateFmt->output = Clock_itoaw(dateFmt->output, z, '0', 2);
}
} else {
Tcl_Obj * objPtr;
const char *s;
Tcl_Size len;
/* convert seconds to local seconds to obtain tzName object */
if (ConvertUTCToLocal(opts->dataPtr, opts->interp,
&dateFmt->date, opts->timezoneObj,
GREGORIAN_CHANGE_DATE) != TCL_OK) {
return TCL_ERROR;
}
objPtr = dateFmt->date.tzName;
s = TclGetStringFromObj(objPtr, &len);
if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
return TCL_ERROR;
}
memcpy(dateFmt->output, s, len + 1);
dateFmt->output += len;
}
return TCL_OK;
}
static int
ClockFmtToken_LocaleERA_Proc(
ClockFmtScnCmdArgs *opts,
DateFormat *dateFmt,
TCL_UNUSED(ClockFormatToken *),
TCL_UNUSED(int *))
{
Tcl_Obj *mcObj;
const char *s;
Tcl_Size len;
if (dateFmt->date.isBce) {
mcObj = ClockMCGet(opts, MCLIT_BCE);
} else {
mcObj = ClockMCGet(opts, MCLIT_CE);
}
if (mcObj == NULL) {
return TCL_ERROR;
}
s = TclGetStringFromObj(mcObj, &len);
if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
return TCL_ERROR;
}
memcpy(dateFmt->output, s, len + 1);
dateFmt->output += len;
return TCL_OK;
}
static int
ClockFmtToken_LocaleERAYear_Proc(
ClockFmtScnCmdArgs *opts,
DateFormat *dateFmt,
ClockFormatToken *tok,
int *val)
{
Tcl_Size rowc;
Tcl_Obj **rowv;
if (dateFmt->localeEra == NULL) {
Tcl_Obj *mcObj = ClockMCGet(opts, MCLIT_LOCALE_ERAS);
if (mcObj == NULL) {
return TCL_ERROR;
}
if (TclListObjGetElements(opts->interp, mcObj, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
if (rowc != 0) {
dateFmt->localeEra = LookupLastTransition(opts->interp,
dateFmt->date.localSeconds, rowc, rowv, NULL);
}
if (dateFmt->localeEra == NULL) {
dateFmt->localeEra = (Tcl_Obj*)1;
}
}
/* if no LOCALE_ERAS in catalog or era not found */
if (dateFmt->localeEra == (Tcl_Obj*)1) {
if (FrmResultAllocate(dateFmt, 11) != TCL_OK) {
return TCL_ERROR;
}
if (*tok->tokWord.start == 'C') { /* %EC */
*val = dateFmt->date.year / 100;
dateFmt->output = Clock_itoaw(dateFmt->output, *val, '0', 2);
} else { /* %Ey */
*val = dateFmt->date.year % 100;
dateFmt->output = Clock_itoaw(dateFmt->output, *val, '0', 2);
}
} else {
Tcl_Obj *objPtr;
const char *s;
Tcl_Size len;
if (*tok->tokWord.start == 'C') { /* %EC */
if (Tcl_ListObjIndex(opts->interp, dateFmt->localeEra, 1,
&objPtr) != TCL_OK) {
return TCL_ERROR;
}
} else { /* %Ey */
if (Tcl_ListObjIndex(opts->interp, dateFmt->localeEra, 2,
&objPtr) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(opts->interp, objPtr, val) != TCL_OK) {
return TCL_ERROR;
}
*val = dateFmt->date.year - *val;
/* if year in locale numerals */
if (*val >= 0 && *val < 100) {
/* year as integer */
Tcl_Obj * mcObj = ClockMCGet(opts, MCLIT_LOCALE_NUMERALS);
if (mcObj == NULL) {
return TCL_ERROR;
}
if (Tcl_ListObjIndex(opts->interp, mcObj, *val, &objPtr) != TCL_OK) {
return TCL_ERROR;
}
} else {
/* year as integer */
if (FrmResultAllocate(dateFmt, 11) != TCL_OK) {
return TCL_ERROR;
}
dateFmt->output = Clock_itoaw(dateFmt->output, *val, '0', 2);
return TCL_OK;
}
}
s = TclGetStringFromObj(objPtr, &len);
if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
return TCL_ERROR;
}
memcpy(dateFmt->output, s, len + 1);
dateFmt->output += len;
}
return TCL_OK;
}
/*
* Descriptors for the various fields in [clock format].
*/
static const char *FmtSTokenMapIndex =
"demNbByYCHMSIklpaAuwUVzgGjJsntQ";
static const ClockFormatTokenMap FmtSTokenMap[] = {
/* %d */
{CTOKT_INT, "0", 2, 0, 0, 0, offsetof(DateFormat, date.dayOfMonth), NULL, NULL},
/* %e */
{CTOKT_INT, " ", 2, 0, 0, 0, offsetof(DateFormat, date.dayOfMonth), NULL, NULL},
/* %m */
{CTOKT_INT, "0", 2, 0, 0, 0, offsetof(DateFormat, date.month), NULL, NULL},
/* %N */
{CTOKT_INT, " ", 2, 0, 0, 0, offsetof(DateFormat, date.month), NULL, NULL},
/* %b %h */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX | CLFMT_DECR, 0, 12, offsetof(DateFormat, date.month),
NULL, (void *)MCLIT_MONTHS_ABBREV},
/* %B */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX | CLFMT_DECR, 0, 12, offsetof(DateFormat, date.month),
NULL, (void *)MCLIT_MONTHS_FULL},
/* %y */
{CTOKT_INT, "0", 2, 0, 0, 100, offsetof(DateFormat, date.year), NULL, NULL},
/* %Y */
{CTOKT_INT, "0", 4, 0, 0, 0, offsetof(DateFormat, date.year), NULL, NULL},
/* %C */
{CTOKT_INT, "0", 2, 0, 100, 0, offsetof(DateFormat, date.year), NULL, NULL},
/* %H */
{CTOKT_INT, "0", 2, 0, 3600, 24, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
/* %M */
{CTOKT_INT, "0", 2, 0, 60, 60, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
/* %S */
{CTOKT_INT, "0", 2, 0, 0, 60, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
/* %I */
{CTOKT_INT, "0", 2, CLFMT_CALC, 0, 0, offsetof(DateFormat, date.secondOfDay),
ClockFmtToken_HourAMPM_Proc, NULL},
/* %k */
{CTOKT_INT, " ", 2, 0, 3600, 24, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
/* %l */
{CTOKT_INT, " ", 2, CLFMT_CALC, 0, 0, offsetof(DateFormat, date.secondOfDay),
ClockFmtToken_HourAMPM_Proc, NULL},
/* %p %P */
{CTOKT_INT, NULL, 0, 0, 0, 0, offsetof(DateFormat, date.secondOfDay),
ClockFmtToken_AMPM_Proc, NULL},
/* %a */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, offsetof(DateFormat, date.dayOfWeek),
NULL, (void *)MCLIT_DAYS_OF_WEEK_ABBREV},
/* %A */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, offsetof(DateFormat, date.dayOfWeek),
NULL, (void *)MCLIT_DAYS_OF_WEEK_FULL},
/* %u */
{CTOKT_INT, " ", 1, 0, 0, 0, offsetof(DateFormat, date.dayOfWeek), NULL, NULL},
/* %w */
{CTOKT_INT, " ", 1, 0, 0, 7, offsetof(DateFormat, date.dayOfWeek), NULL, NULL},
/* %U %W */
{CTOKT_INT, "0", 2, CLFMT_CALC, 0, 0, offsetof(DateFormat, date.dayOfYear),
ClockFmtToken_WeekOfYear_Proc, NULL},
/* %V */
{CTOKT_INT, "0", 2, 0, 0, 0, offsetof(DateFormat, date.iso8601Week), NULL, NULL},
/* %z %Z */
{CFMTT_PROC, NULL, 0, 0, 0, 0, 0,
ClockFmtToken_TimeZone_Proc, NULL},
/* %g */
{CTOKT_INT, "0", 2, 0, 0, 100, offsetof(DateFormat, date.iso8601Year), NULL, NULL},
/* %G */
{CTOKT_INT, "0", 4, 0, 0, 0, offsetof(DateFormat, date.iso8601Year), NULL, NULL},
/* %j */
{CTOKT_INT, "0", 3, 0, 0, 0, offsetof(DateFormat, date.dayOfYear), NULL, NULL},
/* %J */
{CTOKT_WIDE, "0", 7, 0, 0, 0, offsetof(DateFormat, date.julianDay), NULL, NULL},
/* %s */
{CTOKT_WIDE, "0", 1, 0, 0, 0, offsetof(DateFormat, date.seconds), NULL, NULL},
/* %n */
{CTOKT_CHAR, "\n", 0, 0, 0, 0, 0, NULL, NULL},
/* %t */
{CTOKT_CHAR, "\t", 0, 0, 0, 0, 0, NULL, NULL},
/* %Q */
{CFMTT_PROC, NULL, 0, 0, 0, 0, 0,
ClockFmtToken_StarDate_Proc, NULL},
};
static const char *FmtSTokenMapAliasIndex[2] = {
"hPWZ",
"bpUz"
};
static const char *FmtETokenMapIndex = "EJjys";
static const ClockFormatTokenMap FmtETokenMap[] = {
/* %EE */
{CFMTT_PROC, NULL, 0, 0, 0, 0, 0,
ClockFmtToken_LocaleERA_Proc, NULL},
/* %EJ */
{CFMTT_PROC, NULL, 0, 0, 0, 0, 0, /* calendar JDN starts at midnight */
ClockFmtToken_JDN_Proc, NULL},
/* %Ej */
{CFMTT_PROC, NULL, 0, 0, 0, 0, (SECONDS_PER_DAY/2), /* astro JDN starts at noon */
ClockFmtToken_JDN_Proc, NULL},
/* %Ey %EC */
{CTOKT_INT, NULL, 0, 0, 0, 0, offsetof(DateFormat, date.year),
ClockFmtToken_LocaleERAYear_Proc, NULL},
/* %Es */
{CTOKT_WIDE, "0", 1, 0, 0, 0, offsetof(DateFormat, date.localSeconds), NULL, NULL},
};
static const char *FmtETokenMapAliasIndex[2] = {
"C",
"y"
};
static const char *FmtOTokenMapIndex = "dmyHIMSuw";
static const ClockFormatTokenMap FmtOTokenMap[] = {
/* %Od %Oe */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.dayOfMonth),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
/* %Om */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.month),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
/* %Oy */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.year),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
/* %OH %Ok */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 3600, 24, offsetof(DateFormat, date.secondOfDay),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
/* %OI %Ol */
{CTOKT_INT, NULL, 0, CLFMT_CALC | CLFMT_LOCALE_INDX, 0, 0, offsetof(DateFormat, date.secondOfDay),
ClockFmtToken_HourAMPM_Proc, (void *)MCLIT_LOCALE_NUMERALS},
/* %OM */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 60, 60, offsetof(DateFormat, date.secondOfDay),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
/* %OS */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 60, offsetof(DateFormat, date.secondOfDay),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
/* %Ou */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.dayOfWeek),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
/* %Ow */
{CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, offsetof(DateFormat, date.dayOfWeek),
NULL, (void *)MCLIT_LOCALE_NUMERALS},
};
static const char *FmtOTokenMapAliasIndex[2] = {
"ekl",
"dHI"
};
static const ClockFormatTokenMap FmtWordTokenMap = {
CTOKT_WORD, NULL, 0, 0, 0, 0, 0, NULL, NULL
};
/*
*----------------------------------------------------------------------
*/
ClockFmtScnStorage *
ClockGetOrParseFmtFormat(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *formatObj) /* Format container */
{
ClockFmtScnStorage *fss;
fss = Tcl_GetClockFrmScnFromObj(interp, formatObj);
if (fss == NULL) {
return NULL;
}
/* if format (fmtTok) already tokenized */
if (fss->fmtTok != NULL) {
return fss;
}
Tcl_MutexLock(&ClockFmtMutex);
/* first time formatting - tokenize format */
if (fss->fmtTok == NULL) {
ClockFormatToken *tok, *fmtTok;
unsigned tokCnt;
const char *p, *e, *cp;
e = p = HashEntry4FmtScn(fss)->key.string;
e += strlen(p);
/* estimate token count by % char and format length */
fss->fmtTokC = EstimateTokenCount(p, e);
fmtTok = tok = (ClockFormatToken *)Tcl_Alloc(sizeof(*tok) * fss->fmtTokC);
memset(tok, 0, sizeof(*tok));
tokCnt = 1;
while (p < e) {
switch (*p) {
case '%': {
const ClockFormatTokenMap *fmtMap = FmtSTokenMap;
const char *mapIndex = FmtSTokenMapIndex;
const char **aliasIndex = FmtSTokenMapAliasIndex;
if (p + 1 >= e) {
goto word_tok;
}
p++;
/* try to find modifier: */
switch (*p) {
case '%':
/* begin new word token - don't join with previous word token,
* because current mapping should be "...%%..." -> "...%..." */
tok->map = &FmtWordTokenMap;
tok->tokWord.start = p;
tok->tokWord.end = p + 1;
AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *);
tokCnt++;
p++;
continue;
case 'E':
fmtMap = FmtETokenMap,
mapIndex = FmtETokenMapIndex,
aliasIndex = FmtETokenMapAliasIndex;
p++;
break;
case 'O':
fmtMap = FmtOTokenMap,
mapIndex = FmtOTokenMapIndex,
aliasIndex = FmtOTokenMapAliasIndex;
p++;
break;
}
/* search direct index */
cp = strchr(mapIndex, *p);
if (!cp || *cp == '\0') {
/* search wrapper index (multiple chars for same token) */
cp = strchr(aliasIndex[0], *p);
if (!cp || *cp == '\0') {
p--;
if (fmtMap != FmtSTokenMap) {
p--;
}
goto word_tok;
}
cp = strchr(mapIndex, aliasIndex[1][cp - aliasIndex[0]]);
if (!cp || *cp == '\0') { /* unexpected, but ... */
#ifdef DEBUG
Tcl_Panic("token \"%c\" has no map in wrapper resolver", *p);
#endif
p--;
if (fmtMap != FmtSTokenMap) {
p--;
}
goto word_tok;
}
}
tok->map = &fmtMap[cp - mapIndex];
tok->tokWord.start = p;
/* next token */
AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *);
tokCnt++;
p++;
continue;
}
default:
word_tok:
{
/* try continue with previous word token */
ClockFormatToken *wordTok = tok - 1;
if (wordTok < fmtTok || wordTok->map != &FmtWordTokenMap) {
/* start with new word token */
wordTok = tok;
wordTok->tokWord.start = p;
wordTok->map = &FmtWordTokenMap;
}
do {
p = Tcl_UtfNext(p);
} while (p < e && *p != '%');
wordTok->tokWord.end = p;
if (wordTok == tok) {
AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *);
tokCnt++;
}
}
break;
}
}
/* correct count of real used tokens and free mem if desired
* (1 is acceptable delta to prevent memory fragmentation) */
if (fss->fmtTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) {
if ((tok = (ClockFormatToken *)
Tcl_AttemptRealloc(fmtTok, tokCnt * sizeof(*tok))) != NULL) {
fmtTok = tok;
}
}
/* now we're ready - assign now to storage (note the threaded race condition) */
fss->fmtTok = fmtTok;
fss->fmtTokC = tokCnt;
}
Tcl_MutexUnlock(&ClockFmtMutex);
return fss;
}
/*
*----------------------------------------------------------------------
*/
int
ClockFormat(
DateFormat *dateFmt, /* Date fields used for parsing & converting */
ClockFmtScnCmdArgs *opts) /* Command options */
{
ClockFmtScnStorage *fss;
ClockFormatToken *tok;
const ClockFormatTokenMap *map;
char resMem[MIN_FMT_RESULT_BLOCK_ALLOC];
/* get localized format */
if (ClockLocalizeFormat(opts) == NULL) {
return TCL_ERROR;
}
if (!(fss = ClockGetOrParseFmtFormat(opts->interp, opts->formatObj))
|| !(tok = fss->fmtTok)) {
return TCL_ERROR;
}
/* result container object */
dateFmt->resMem = resMem;
dateFmt->resEnd = dateFmt->resMem + sizeof(resMem);
if (fss->fmtMinAlloc > sizeof(resMem)) {
dateFmt->resMem = (char *)Tcl_AttemptAlloc(fss->fmtMinAlloc);
if (dateFmt->resMem == NULL) {
return TCL_ERROR;
}
dateFmt->resEnd = dateFmt->resMem + fss->fmtMinAlloc;
}
dateFmt->output = dateFmt->resMem;
*dateFmt->output = '\0';
/* do format each token */
for (; tok->map != NULL; tok++) {
map = tok->map;
switch (map->type) {
case CTOKT_INT: {
int val = *IntFieldAt(dateFmt, map->offs);
if (map->fmtproc == NULL) {
if (map->flags & CLFMT_DECR) {
val--;
}
if (map->flags & CLFMT_INCR) {
val++;
}
if (map->divider) {
val /= map->divider;
}
if (map->divmod) {
val %= map->divmod;
}
} else {
if (map->fmtproc(opts, dateFmt, tok, &val) != TCL_OK) {
goto done;
}
/* if not calculate only (output inside fmtproc) */
if (!(map->flags & CLFMT_CALC)) {
continue;
}
}
if (!(map->flags & CLFMT_LOCALE_INDX)) {
if (FrmResultAllocate(dateFmt, 11) != TCL_OK) {
goto error;
}
if (map->width) {
dateFmt->output = Clock_itoaw(
dateFmt->output, val, *map->tostr, map->width);
} else {
dateFmt->output += sprintf(dateFmt->output, map->tostr, val);
}
} else {
const char *s;
Tcl_Obj * mcObj = ClockMCGet(opts, PTR2INT(map->data) /* mcKey */);
if (mcObj == NULL) {
goto error;
}
if (Tcl_ListObjIndex(opts->interp, mcObj, val, &mcObj) != TCL_OK
|| mcObj == NULL) {
goto error;
}
s = TclGetString(mcObj);
if (FrmResultAllocate(dateFmt, mcObj->length) != TCL_OK) {
goto error;
}
memcpy(dateFmt->output, s, mcObj->length + 1);
dateFmt->output += mcObj->length;
}
break;
}
case CTOKT_WIDE: {
Tcl_WideInt val = *WideFieldAt(dateFmt, map->offs);
if (FrmResultAllocate(dateFmt, 21) != TCL_OK) {
goto error;
}
if (map->width) {
dateFmt->output = Clock_witoaw(dateFmt->output, val, *map->tostr, map->width);
} else {
dateFmt->output += sprintf(dateFmt->output, map->tostr, val);
}
break;
}
case CTOKT_CHAR:
if (FrmResultAllocate(dateFmt, 1) != TCL_OK) {
goto error;
}
*dateFmt->output++ = *map->tostr;
break;
case CFMTT_PROC:
if (map->fmtproc(opts, dateFmt, tok, NULL) != TCL_OK) {
goto error;
}
break;
case CTOKT_WORD: {
Tcl_Size len = tok->tokWord.end - tok->tokWord.start;
if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
goto error;
}
if (len == 1) {
*dateFmt->output++ = *tok->tokWord.start;
} else {
memcpy(dateFmt->output, tok->tokWord.start, len);
dateFmt->output += len;
}
break;
}
}
}
goto done;
error:
if (dateFmt->resMem != resMem) {
Tcl_Free(dateFmt->resMem);
}
dateFmt->resMem = NULL;
done:
if (dateFmt->resMem) {
size_t size;
Tcl_Obj *result;
TclNewObj(result);
result->length = dateFmt->output - dateFmt->resMem;
size = result->length + 1;
if (dateFmt->resMem == resMem) {
result->bytes = (char *)Tcl_AttemptAlloc(size);
if (result->bytes == NULL) {
return TCL_ERROR;
}
memcpy(result->bytes, dateFmt->resMem, size);
} else if ((dateFmt->resEnd - dateFmt->resMem) / size > MAX_FMT_RESULT_THRESHOLD) {
result->bytes = (char *)Tcl_AttemptRealloc(dateFmt->resMem, size);
if (result->bytes == NULL) {
result->bytes = dateFmt->resMem;
}
} else {
result->bytes = dateFmt->resMem;
}
/* save last used buffer length */
if (dateFmt->resMem != resMem
&& fss->fmtMinAlloc < size + MIN_FMT_RESULT_BLOCK_DELTA) {
fss->fmtMinAlloc = size + MIN_FMT_RESULT_BLOCK_DELTA;
}
result->bytes[result->length] = '\0';
Tcl_SetObjResult(opts->interp, result);
return TCL_OK;
}
return TCL_ERROR;
}
void
ClockFrmScnClearCaches(void)
{
Tcl_MutexLock(&ClockFmtMutex);
/* clear caches ... */
Tcl_MutexUnlock(&ClockFmtMutex);
}
void
ClockFrmScnFinalize(void)
{
if (!initialized) {
return;
}
Tcl_MutexLock(&ClockFmtMutex);
#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
/* clear GC */
ClockFmtScnStorage_GC.stackPtr = NULL;
ClockFmtScnStorage_GC.stackBound = NULL;
ClockFmtScnStorage_GC.count = 0;
#endif
if (initialized) {
initialized = 0;
Tcl_DeleteHashTable(&FmtScnHashTable);
}
Tcl_MutexUnlock(&ClockFmtMutex);
Tcl_MutexFinalize(&ClockFmtMutex);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCmdAH.c.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
struct ForeachState {
Tcl_Obj *bodyPtr; /* The script body of the command. */
Tcl_Size bodyIdx; /* The argument index of the body. */
Tcl_Size j, maxj; /* Number of loop iterations. */
Tcl_Size numLists; /* Count of value lists. */
Tcl_Size *index; /* Array of value list indices. */
| | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
struct ForeachState {
Tcl_Obj *bodyPtr; /* The script body of the command. */
Tcl_Size bodyIdx; /* The argument index of the body. */
Tcl_Size j, maxj; /* Number of loop iterations. */
Tcl_Size numLists; /* Count of value lists. */
Tcl_Size *index; /* Array of value list indices. */
Tcl_Size *varcList; /* # loop variables per list. */
Tcl_Obj ***varvList; /* Array of var name lists. */
Tcl_Obj **vCopyList; /* Copies of var name list arguments. */
Tcl_Size *argcList; /* Array of value list sizes. */
Tcl_Obj ***argvList; /* Array of value lists. */
Tcl_Obj **aCopyList; /* Copies of value list arguments. */
Tcl_Obj *resultList; /* List of result values from the loop body,
* or NULL if we're not collecting them
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | static inline void ForeachCleanup(Tcl_Interp *interp, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | static inline void ForeachCleanup(Tcl_Interp *interp, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); static int EachloopCmd(Tcl_Interp *interp, int collect, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; static Tcl_NRPostProc ForSetupCallback; static Tcl_NRPostProc ForCondCallback; static Tcl_NRPostProc ForNextCallback; static Tcl_NRPostProc ForPostNextCallback; |
| ︙ | ︙ | |||
420 421 422 423 424 425 426 | * - *profilePtr is set to encoding error handling profile * - *failVarPtr is set to -failindex option value or NULL * On error, all of the above are uninitialized. * *------------------------------------------------------------------------ */ static int | | | | | | | | | < | | < < | | < | | < | < | 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 |
* - *profilePtr is set to encoding error handling profile
* - *failVarPtr is set to -failindex option value or NULL
* On error, all of the above are uninitialized.
*
*------------------------------------------------------------------------
*/
static int
EncodingConvertParseOptions(
Tcl_Interp *interp, /* For error messages. May be NULL */
int objc, /* Number of arguments */
Tcl_Obj *const objv[], /* Argument objects as passed to command. */
Tcl_Encoding *encPtr, /* Where to store the encoding */
Tcl_Obj **dataObjPtr, /* Where to store ptr to Tcl_Obj containing data */
int *profilePtr, /* Bit mask of encoding option profile */
Tcl_Obj **failVarPtr) /* Where to store -failindex option value */
{
static const char *const options[] = {"-profile", "-failindex", NULL};
enum convertfromOptions { PROFILE, FAILINDEX } optIndex;
Tcl_Encoding encoding;
Tcl_Obj *dataObj;
Tcl_Obj *failVarObj;
int profile = TCL_ENCODING_PROFILE_STRICT;
/*
* Possible combinations:
* 1) data -> objc = 2
* 2) ?options? encoding data -> objc >= 3
* It is intentional that specifying option forces encoding to be
* specified. Less prone to user error. This should have always been
* the case even in 8.6 imho where there were no options (ie (1)
* should never have been allowed)
*/
if (objc == 1) {
numArgsError: /* ONLY jump here if nothing needs to be freed!!! */
Tcl_WrongNumArgs(interp, 1, objv,
"?-profile profile? ?-failindex var? encoding data");
((Interp *)interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv, "data");
return TCL_ERROR;
}
failVarObj = NULL;
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
dataObj = objv[1];
} else {
int argIndex;
for (argIndex = 1; argIndex < (objc-2); ++argIndex) {
if (Tcl_GetIndexFromObj(interp, objv[argIndex], options, "option",
0, &optIndex) != TCL_OK) {
return TCL_ERROR;
}
if (++argIndex == (objc - 2)) {
goto numArgsError;
}
switch (optIndex) {
case PROFILE:
if (TclEncodingProfileNameToId(interp,
Tcl_GetString(objv[argIndex]), &profile) != TCL_OK) {
return TCL_ERROR;
}
break;
case FAILINDEX:
failVarObj = objv[argIndex];
break;
}
}
/* Get encoding after opts so no need to free it on option error */
if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
return TCL_ERROR;
}
dataObj = objv[objc - 1];
}
*encPtr = encoding;
*dataObjPtr = dataObj;
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
Tcl_Size length = 0; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
int flags;
int result;
Tcl_Obj *failVarObj;
Tcl_Size errorLocation;
| | < | | | 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 |
Tcl_Size length = 0; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
int flags;
int result;
Tcl_Obj *failVarObj;
Tcl_Size errorLocation;
if (EncodingConvertParseOptions(interp, objc, objv, &encoding, &data,
&flags, &failVarObj) != TCL_OK) {
return TCL_ERROR;
}
/*
* Convert the string into a byte array in 'ds'.
*/
bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length);
if (bytesPtr == NULL) {
return TCL_ERROR;
}
result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags,
&ds, failVarObj ? &errorLocation : NULL);
/* NOTE: ds must be freed beyond this point even on error */
switch (result) {
case TCL_OK:
errorLocation = TCL_INDEX_NONE;
break;
case TCL_ERROR:
/* Error in parameters. Should not happen. interp will have error */
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
/*
* TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
* data as was converted.
*/
if (failVarObj) {
Tcl_Obj *failIndex;
TclNewIndexObj(failIndex, errorLocation);
| | < < < | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
/*
* TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
* data as was converted.
*/
if (failVarObj) {
Tcl_Obj *failIndex;
TclNewIndexObj(failIndex, errorLocation);
if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
}
/*
* Note that we cannot use Tcl_DStringResult here because it will
* truncate the string at the first null byte.
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* String to convert */
Tcl_DString ds; /* Buffer to hold the byte array */
Tcl_Encoding encoding; /* Encoding to use */
| | | < | | | | 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 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* String to convert */
Tcl_DString ds; /* Buffer to hold the byte array */
Tcl_Encoding encoding; /* Encoding to use */
Tcl_Size length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
int result;
int flags;
Tcl_Obj *failVarObj;
Tcl_Size errorLocation;
if (EncodingConvertParseOptions(interp, objc, objv, &encoding, &data,
&flags, &failVarObj) != TCL_OK) {
return TCL_ERROR;
}
/*
* Convert the string to a byte array in 'ds'
*/
stringPtr = TclGetStringFromObj(data, &length);
result = Tcl_UtfToExternalDStringEx(interp, encoding, stringPtr, length, flags,
&ds, failVarObj ? &errorLocation : NULL);
/* NOTE: ds must be freed beyond this point even on error */
switch (result) {
case TCL_OK:
errorLocation = TCL_INDEX_NONE;
break;
case TCL_ERROR:
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 682 |
}
/*
* TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
* data as was converted.
*/
if (failVarObj) {
Tcl_Obj *failIndex;
TclNewIndexObj(failIndex, errorLocation);
| > | < < < | | | | | 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 |
}
/*
* TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
* data as was converted.
*/
if (failVarObj) {
Tcl_Obj *failIndex;
TclNewIndexObj(failIndex, errorLocation);
if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
(unsigned char*) Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
/* We're done with the encoding */
Tcl_FreeEncoding(encoding);
return TCL_OK;
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
dirListObj = objv[1];
if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected directory list but got \"%s\"",
TclGetString(dirListObj)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
| | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
dirListObj = objv[1];
if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected directory list but got \"%s\"",
TclGetString(dirListObj)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
(char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, dirListObj);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 |
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?encoding?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp,
| | | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?encoding?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_GetEncodingName(NULL), -1));
} else {
return Tcl_SetSystemEncoding(interp, TclGetString(objv[1]));
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1201 1202 1203 1204 1205 1206 1207 |
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the access time not available */
if (Tcl_GetAccessTimeFromStat(&buf) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 |
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the access time not available */
if (Tcl_GetAccessTimeFromStat(&buf) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not get access time for file \"%s\"",
TclGetString(objv[1])));
return TCL_ERROR;
}
#endif
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
|
| ︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 |
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the modification time not available */
if (Tcl_GetModificationTimeFromStat(&buf) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 |
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the modification time not available */
if (Tcl_GetModificationTimeFromStat(&buf) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not get modification time for file \"%s\"",
TclGetString(objv[1])));
return TCL_ERROR;
}
#endif
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
* platforms. [Bug 698146]
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
| | | 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(buf.st_size));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FileAttrIsDirectoryCmd --
|
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 |
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(interp, objv[1]);
/* Note normPathPtr owned by Tcl, no need to free it */
if (normPathPtr) {
| | | 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 |
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(interp, objv[1]);
/* Note normPathPtr owned by Tcl, no need to free it */
if (normPathPtr) {
if (TclIsZipfsPath(TclGetString(normPathPtr))) {
return CheckAccess(interp, objv[1], F_OK);
}
/* Not zipfs, try native. */
}
/*
* Note use objv[1] below, NOT normPathPtr even if not NULL because
|
| ︙ | ︙ | |||
1931 1932 1933 1934 1935 1936 1937 |
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
fsInfo = Tcl_FSFileSystemInfo(objv[1]);
if (fsInfo == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
| | | 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 |
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
fsInfo = Tcl_FSFileSystemInfo(objv[1]);
if (fsInfo == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
TclGetString(objv[1]), (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, fsInfo);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 |
}
res = Tcl_FSSplitPath(objv[1], (Tcl_Size *)NULL);
if (res == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
| | | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 |
}
res = Tcl_FSSplitPath(objv[1], (Tcl_Size *)NULL);
if (res == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
(char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2183 2184 2185 2186 2187 2188 2189 |
} else {
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
if (separatorObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
| | | 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 |
} else {
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
if (separatorObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
TclGetString(objv[1]), (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, separatorObj);
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2356 2357 2358 2359 2360 2361 2362 |
Tcl_Obj *field, *value, *result;
unsigned short mode;
if (varName == NULL) {
TclNewObj(result);
Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue) \
| | | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 |
Tcl_Obj *field, *value, *result;
unsigned short mode;
if (varName == NULL) {
TclNewObj(result);
Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue) \
Tcl_DictObjPut(NULL, result, \
Tcl_NewStringObj((key), -1), \
(objValue));
DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
|
| ︙ | ︙ | |||
2821 2822 2823 2824 2825 2826 2827 |
/* List */
/* Variables */
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
| | | | | | 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 |
/* List */
/* Variables */
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
result = TclListObjLength(interp, statePtr->vCopyList[i],
&statePtr->varcList[i]);
if (result != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s varlist is empty",
(statePtr->resultList != NULL ? "lmap" : "foreach")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
(statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
"NEEDVARS", (char *)NULL);
result = TCL_ERROR;
goto done;
}
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
/* Values */
if (TclObjTypeHasProc(objv[2+i*2],indexProc)) {
/* Special case for AbstractList */
statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
/* Don't compute values here, wait until the last moment */
statePtr->argcList[i] = TclObjTypeLength(statePtr->aCopyList[i]);
} else {
/* List values */
statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
result = TclListObjGetElements(interp, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
if (result != TCL_OK) {
goto done;
}
}
/* account for variable <> value mismatch */
j = statePtr->argcList[i] / statePtr->varcList[i];
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
/*
* Definitions for [lseq] command
*/
static const char *const seq_operations[] = {
"..", "to", "count", "by", NULL
};
| | < | < < < | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
/*
* Definitions for [lseq] command
*/
static const char *const seq_operations[] = {
"..", "to", "count", "by", NULL
};
typedef enum {
LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY
} SequenceOperators;
typedef enum {
NoneArg, NumericArg, RangeKeywordArg, ErrArg, LastArg = 8
} SequenceDecoded;
/*
* Forward declarations for procedures defined in this file:
*/
static int DictionaryCompare(const char *left, const char *right);
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
{
Tcl_Obj *boolObj;
if (objc <= 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
TclGetString(objv[0])));
| | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
{
Tcl_Obj *boolObj;
if (objc <= 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL);
return TCL_ERROR;
}
/*
* At this point, objv[1] refers to the main expression to test. The
* arguments after the expression must be "then" (optional) and a script
* to execute if the expression is true.
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 |
* (optional) and a script to execute if the expression is true.
*/
if (i >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
clause));
| | | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
* (optional) and a script to execute if the expression is true.
*/
if (i >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
clause));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL);
return TCL_ERROR;
}
if (!thenScriptIndex) {
TclNewObj(boolObj);
Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1],
INT2PTR(i), boolObj);
return Tcl_NRExprObj(interp, objv[i], boolObj);
|
| ︙ | ︙ | |||
342 343 344 345 346 347 348 |
goto missingScript;
}
}
if (i < objc - 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args: extra words after \"else\" clause in \"if\" command",
-1));
| | | | 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 |
goto missingScript;
}
}
if (i < objc - 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args: extra words after \"else\" clause in \"if\" command",
-1));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
/*
* TIP #280. Make invoking context available to branch/else.
*/
return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr, thenScriptIndex);
}
return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
missingScript:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no script following \"%s\" argument",
TclGetString(objv[i-1])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IncrObjCmd --
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 |
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
| | | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (char *)NULL);
return TCL_ERROR;
}
/*
* Build a return list containing the arguments.
*/
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
| | | | 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 |
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (char *)NULL);
return TCL_ERROR;
}
/*
* Here we used to return procPtr->bodyPtr, except when the body was
* bytecompiled - in that case, the return was a copy of the body's string
* rep. In order to better isolate the implementation details of the
* compiler/engine subsystem, we now always return a copy of the string
* rep. It is important to return a copy so that later manipulations of
* the object do not invalidate the internal rep.
*/
bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
if (Tcl_FindHashEntry(&addedCommandsTable,
| | | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 |
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
if (Tcl_FindHashEntry(&addedCommandsTable,
elemObjPtr) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
} else {
TclDecrRefCount(elemObjPtr);
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 |
argName = TclGetString(objv[2]);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
| | | | | | 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 |
argName = TclGetString(objv[2]);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
(char *)NULL);
return TCL_ERROR;
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)
&& (strcmp(argName, localPtr->name) == 0)) {
if (localPtr->defValuePtr != NULL) {
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
localPtr->defValuePtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
Tcl_Obj *nullObjPtr;
TclNewObj(nullObjPtr);
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
nullObjPtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
}
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\" doesn't have an argument \"%s\"",
procName, argName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoErrorStackCmd --
|
| ︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 |
cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr);
}
if (corPtr->caller.cmdFramePtr) {
*cmdFramePtrPtr = corPtr->caller.cmdFramePtr;
}
corPtr = corPtr->callerEEPtr->corPtr;
}
| | | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 |
cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr);
}
if (corPtr->caller.cmdFramePtr) {
*cmdFramePtrPtr = corPtr->caller.cmdFramePtr;
}
corPtr = corPtr->callerEEPtr->corPtr;
}
topLevel += *cmdFramePtrPtr ? (*cmdFramePtrPtr)->level : 1;
if (iPtr->cmdFramePtr && topLevel != iPtr->cmdFramePtr->level) {
framePtr = iPtr->cmdFramePtr;
while (framePtr) {
framePtr->level = topLevel--;
framePtr = framePtr->nextPtr;
}
if (topLevel) {
Tcl_Panic("Broken frame level calculation");
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
}
if ((level > topLevel) || (level <= - topLevel)) {
levelError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
| | | 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 |
}
if ((level > topLevel) || (level <= - topLevel)) {
levelError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
TclGetString(objv[1]), (char *)NULL);
code = TCL_ERROR;
goto done;
}
/*
* Let us convert to relative so that we know how many levels to go back
*/
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 |
/*
* This array is indexed by the TCL_LOCATION_... values, except
* for _LAST.
*/
static const char *const typeString[TCL_LOCATION_LAST] = {
"eval", "eval", "eval", "precompiled", "source", "proc"
};
| | > > > > > | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 |
/*
* This array is indexed by the TCL_LOCATION_... values, except
* for _LAST.
*/
static const char *const typeString[TCL_LOCATION_LAST] = {
"eval", "eval", "eval", "precompiled", "source", "proc"
};
Proc *procPtr = NULL;
int needsFree = -1;
if (!framePtr) {
goto precompiled;
}
procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
/*
* Pull the information and construct the dictionary to return, as list.
* Regarding use of the CmdFrame fields see tclInt.h, and its definition.
*/
#define ADD_PAIR(name, value) \
TclNewLiteralStringObj(tmpObj, name); \
|
| ︙ | ︙ | |||
1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
} else {
ADD_PAIR("line", Tcl_NewWideIntObj(1));
}
ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PREBC:
/*
* Precompiled. Result contains the type as signal, nothing else.
*/
| > < | | 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
} else {
ADD_PAIR("line", Tcl_NewWideIntObj(1));
}
ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PREBC:
precompiled:
/*
* Precompiled. Result contains the type as signal, nothing else.
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[TCL_LOCATION_PREBC], -1));
break;
case TCL_LOCATION_BC: {
/*
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 |
}
/*
* 'level'. Common to all frame types. Conditional on having an associated
* _visible_ CallFrame.
*/
| | | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
}
/*
* 'level'. Common to all frame types. Conditional on having an associated
* _visible_ CallFrame.
*/
if (framePtr && (framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
CallFrame *current = framePtr->framePtr;
CallFrame *top = iPtr->varFramePtr;
CallFrame *idx;
for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) {
if (idx == current) {
int c = framePtr->framePtr->level;
|
| ︙ | ︙ | |||
1549 1550 1551 1552 1553 1554 1555 |
if (name) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to determine name of host", -1));
| | | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 |
if (name) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to determine name of host", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoLevelCmd --
|
| ︙ | ︙ | |||
1622 1623 1624 1625 1626 1627 1628 |
Tcl_WrongNumArgs(interp, 1, objv, "?number?");
return TCL_ERROR;
levelError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
| | | 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 |
Tcl_WrongNumArgs(interp, 1, objv, "?number?");
return TCL_ERROR;
levelError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
TclGetString(objv[1]), (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoLibraryCmd --
|
| ︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 |
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no library has been specified for Tcl", -1));
| | | 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 |
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no library has been specified for Tcl", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoLoadedCmd --
|
| ︙ | ︙ | |||
1701 1702 1703 1704 1705 1706 1707 |
static int
InfoLoadedCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | | | 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 |
static int
InfoLoadedCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *interpName, *prefix;
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?prefix?");
return TCL_ERROR;
}
if (objc < 2) { /* Get loaded pkgs in all interpreters. */
interpName = NULL;
} else { /* Get pkgs just in specified interp. */
interpName = TclGetString(objv[1]);
}
if (objc < 3) { /* Get loaded files in all packages. */
prefix = NULL;
} else { /* Get pkgs just in specified interp. */
prefix = TclGetString(objv[2]);
}
return TclGetLoadedLibraries(interp, interpName, prefix);
}
/*
*----------------------------------------------------------------------
*
* InfoNameOfExecutableCmd --
*
|
| ︙ | ︙ | |||
1835 1836 1837 1838 1839 1840 1841 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName, *pattern;
const char *simplePattern;
Namespace *nsPtr;
| < < < | 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName, *pattern;
const char *simplePattern;
Namespace *nsPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
|
| ︙ | ︙ | |||
1889 1890 1891 1892 1893 1894 1895 |
* Scan through the effective namespace's command table and create a list
* with all procs that match the pattern. If a specific namespace was
* requested in the pattern, qualify the command names with the namespace
* name.
*/
listPtr = Tcl_NewListObj(0, NULL);
| < | 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 |
* Scan through the effective namespace's command table and create a list
* with all procs that match the pattern. If a specific namespace was
* requested in the pattern, qualify the command names with the namespace
* name.
*/
listPtr = Tcl_NewListObj(0, NULL);
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
|
| ︙ | ︙ | |||
1913 1914 1915 1916 1917 1918 1919 |
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
| | < < | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 |
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
} else {
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
|
| ︙ | ︙ | |||
1943 1944 1945 1946 1947 1948 1949 | elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } } entryPtr = Tcl_NextHashEntry(&search); } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 |
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2167 2168 2169 2170 2171 2172 2173 |
/*
* There's one special case: safe child interpreters can't see aliases as
* aliases as they're part of the security mechanisms.
*/
if (Tcl_IsSafe(interp)
&& (((Command *) command)->objProc == TclAliasObjCmd)) {
| | | 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 |
/*
* There's one special case: safe child interpreters can't see aliases as
* aliases as they're part of the security mechanisms.
*/
if (Tcl_IsSafe(interp)
&& (((Command *) command)->objProc == TclAliasObjCmd)) {
Tcl_AppendResult(interp, "native", (char *)NULL);
} else {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(TclGetCommandTypeName(command), -1));
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 |
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
if (TclObjTypeHasProc(objv[1], getElementsProc)) {
listLen = TclObjTypeLength(objv[1]);
isAbstractList = (listLen ? 1 : 0);
| | < | | > | < | | 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 |
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
if (TclObjTypeHasProc(objv[1], getElementsProc)) {
listLen = TclObjTypeLength(objv[1]);
isAbstractList = (listLen ? 1 : 0);
if (listLen > 1 && TclObjTypeGetElements(interp, objv[1],
&listLen, &elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
} else if (TclListObjGetElements(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
if (listLen == 0) {
/* No elements to join; default empty result is correct. */
return TCL_OK;
}
if (listLen == 1) {
/* One element; return it */
if (!isAbstractList) {
Tcl_SetObjResult(interp, elemPtrs[0]);
} else {
Tcl_Obj *elemObj;
if (TclObjTypeIndex(interp, objv[1], 0, &elemObj) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, elemObj);
}
return TCL_OK;
}
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
(void)TclGetStringFromObj(joinObjPtr, &length);
if (length == 0) {
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
Tcl_Size i;
TclNewObj(resObjPtr);
for (i = 0; i < listLen; i++) {
|
| ︙ | ︙ | |||
2322 2323 2324 2325 2326 2327 2328 |
* pointers to internal structures. Using Tcl_ListObjIndex does not
* have that problem. However, we now have to IncrRef each elemObj
* (see below). I see that as preferable as duping lists is potentially
* expensive for abstract lists when they have a string representation.
*/
listPtr = objv[1];
| | > | | | | 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 |
* pointers to internal structures. Using Tcl_ListObjIndex does not
* have that problem. However, we now have to IncrRef each elemObj
* (see below). I see that as preferable as duping lists is potentially
* expensive for abstract lists when they have a string representation.
*/
listPtr = objv[1];
if (TclListObjLength(interp, listPtr, &listObjc) != TCL_OK) {
return TCL_ERROR;
}
origListObjc = listObjc;
objc -= 2;
objv += 2;
for (i = 0; i < objc && i < listObjc; ++i) {
Tcl_Obj *elemObj;
if (Tcl_ListObjIndex(interp, listPtr, i, &elemObj) != TCL_OK) {
return TCL_ERROR;
}
/*
* Must incrref elemObj. If the var name being set is same as the
* list value, ObjSetVar2 will shimmer the list to a VAR freeing
* the elements in the list (in case list refCount was 1) BEFORE
* the elemObj is stored in the var. See tests 6.{25,26}
*/
Tcl_IncrRefCount(elemObj);
if (Tcl_ObjSetVar2(interp, *objv++, NULL, elemObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(elemObj);
return TCL_ERROR;
}
Tcl_DecrRefCount(elemObj);
}
objc -= i;
listObjc -= i;
|
| ︙ | ︙ | |||
2376 2377 2378 2379 2380 2381 2382 |
Tcl_Size fromIdx = origListObjc - listObjc;
Tcl_Size toIdx = origListObjc - 1;
if (TclObjTypeHasProc(listPtr, sliceProc)) {
if (TclObjTypeSlice(
interp, listPtr, fromIdx, toIdx, &resultObjPtr) != TCL_OK) {
return TCL_ERROR;
}
| < | | 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 |
Tcl_Size fromIdx = origListObjc - listObjc;
Tcl_Size toIdx = origListObjc - 1;
if (TclObjTypeHasProc(listPtr, sliceProc)) {
if (TclObjTypeSlice(
interp, listPtr, fromIdx, toIdx, &resultObjPtr) != TCL_OK) {
return TCL_ERROR;
}
} else {
resultObjPtr = TclListObjRange(
interp, listPtr, origListObjc - listObjc, origListObjc - 1);
if (resultObjPtr == NULL) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, resultObjPtr);
|
| ︙ | ︙ | |||
2481 2482 2483 2484 2485 2486 2487 |
int copied = 0, result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
| | | 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 |
int copied = 0, result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
/*
* Get the index. "end" is interpreted to be the index after the last
* element, such that using it will cause any inserted elements to be
|
| ︙ | ︙ | |||
2611 2612 2613 2614 2615 2616 2617 |
Tcl_Obj *objPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
| | | 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 |
Tcl_Obj *objPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
* Set the interpreter's object result to an integer object holding the
* length.
|
| ︙ | ︙ | |||
2666 2667 2668 2669 2670 2671 2672 |
}
listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (listPtr == NULL) {
return TCL_ERROR;
}
| | | < | 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 |
}
listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (listPtr == NULL) {
return TCL_ERROR;
}
result = TclListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
return result;
}
/*
* First, extract the element to be returned.
* TclLindexFlat adds a ref count which is handled.
*/
if (objc == 2) {
if (!listLen) {
/* empty list, throw the same error as with index "end" */
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index \"end\" out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (char *)NULL);
return TCL_ERROR;
}
result = Tcl_ListObjIndex(interp, listPtr, (listLen-1), &elemPtr);
if (result != TCL_OK) {
return result;
}
|
| ︙ | ︙ | |||
2778 2779 2780 2781 2782 2783 2784 |
int result;
Tcl_Size listLen, first, last;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
| | | 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 |
int result;
Tcl_Size listLen, first, last;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
2867 2868 2869 2870 2871 2872 2873 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
listObj = objv[1];
| | | 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
listObj = objv[1];
if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) {
return TCL_ERROR;
}
idxc = objc - 2;
if (idxc == 0) {
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
|
| ︙ | ︙ | |||
3004 3005 3006 3007 3008 3009 3010 |
if (TCL_OK != TclGetWideIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
if (elementCount < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
| | | | 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 |
if (TCL_OK != TclGetWideIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
if (elementCount < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
(char *)NULL);
return TCL_ERROR;
}
/*
* Skip forward to the interesting arguments now we've finished parsing.
*/
objc -= 2;
objv += 2;
/* Final sanity check. Do not exceed limits on max list length. */
if (elementCount && objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%" TCL_SIZE_MODIFIER "d elements) exceeded", LIST_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
/*
* Get an empty list object that is allocated large enough to hold each
* init value elementCount times.
|
| ︙ | ︙ | |||
3108 3109 3110 3111 3112 3113 3114 |
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"list first last ?element ...?");
return TCL_ERROR;
}
| | | 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 |
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"list first last ?element ...?");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
* Get the first and last indexes. "end" is interpreted to be the index
* for the last element, such that using it will cause that element to be
|
| ︙ | ︙ | |||
3221 3222 3223 3224 3225 3226 3227 |
if (TclObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) {
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
} /* end Abstract List */
| | | | | 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 |
if (TclObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) {
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
} /* end Abstract List */
if (TclListObjLength(interp, objv[1], &elemc) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the list is empty, just return it. [Bug 1876793]
*/
if (!elemc) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(objv[1])
|| ListObjRepIsShared(objv[1])) { /* Bug 1675044 */
Tcl_Obj *resultObj, **dataArray;
ListRep listRep;
resultObj = Tcl_NewListObj(elemc, NULL);
/* Modify the internal rep in-place */
ListObjGetRep(resultObj, &listRep);
|
| ︙ | ︙ | |||
3438 3439 3440 3441 3442 3443 3444 |
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing starting index", -1));
| | | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 |
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing starting index", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
result = TCL_ERROR;
goto done;
}
i++;
if (objv[i] == objv[objc - 2]) {
/*
* Take copy to prevent shimmering problems. Note that it does
|
| ︙ | ︙ | |||
3462 3463 3464 3465 3466 3467 3468 |
Tcl_IncrRefCount(startPtr);
break;
case LSEARCH_STRIDE: /* -stride */
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
| | | | | | 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 |
Tcl_IncrRefCount(startPtr);
break;
case LSEARCH_STRIDE: /* -stride */
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)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",
"BADSTRIDE", (char *)NULL);
result = TCL_ERROR;
goto done;
}
groupSize = wide;
i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
Tcl_Size j;
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
allocatedIndexVector = 0;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
result = TCL_ERROR;
goto done;
}
/*
* Store the extracted indices for processing by sublist
* extraction. Note that we don't do this using objects because
* that has shimmering problems.
*/
i++;
if (TclListObjGetElements(interp, objv[i],
&sortInfo.indexc, &indices) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
switch (sortInfo.indexc) {
case 0:
sortInfo.indexv = NULL;
|
| ︙ | ︙ | |||
3540 3541 3542 3543 3544 3545 3546 |
TCL_INDEX_NONE, &encoded) != TCL_OK) {
result = TCL_ERROR;
}
if (encoded == (int)TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range",
TclGetString(indices[j])));
| | < | 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 |
TCL_INDEX_NONE, &encoded) != TCL_OK) {
result = TCL_ERROR;
}
if (encoded == (int)TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range",
TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (char *)NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %" TCL_Z_MODIFIER "u)", j));
goto done;
}
|
| ︙ | ︙ | |||
3564 3565 3566 3567 3568 3569 3570 |
* Subindices only make sense if asked for with -index option set.
*/
if (returnSubindices && sortInfo.indexc==0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-subindices cannot be used without -index option", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
| | | | 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 |
* Subindices only make sense if asked for with -index option set.
*/
if (returnSubindices && sortInfo.indexc==0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-subindices cannot be used without -index option", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", (char *)NULL);
result = TCL_ERROR;
goto done;
}
if (bisect && (allMatches || negatedMatch)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-bisect is not compatible with -all or -not", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", (char *)NULL);
result = TCL_ERROR;
goto done;
}
if (mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
|
| ︙ | ︙ | |||
3611 3612 3613 3614 3615 3616 3617 |
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
| | | | | 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 |
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
goto done;
}
/*
* Check for sanity when grouping elements of the overall list together
* because of the -stride option. [TIP #351]
*/
if (groupSize > 1) {
if (listc % groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list size must be a multiple of the stride length",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE",
(char *)NULL);
result = TCL_ERROR;
goto done;
}
if (sortInfo.indexc > 0) {
/*
* Use the first value in the list supplied to -index as the
* offset of the element within each group by which to sort.
*/
groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
if (groupOffset < 0 || groupOffset >= groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"when used with \"-stride\", the leading \"-index\""
" value must be within the group", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BADINDEX", (char *)NULL);
result = TCL_ERROR;
goto done;
}
if (sortInfo.indexc == 1) {
sortInfo.indexc = 0;
sortInfo.indexv = NULL;
} else {
|
| ︙ | ︙ | |||
3703 3704 3705 3706 3707 3708 3709 |
patObj = objv[objc - 1];
patternBytes = NULL;
if (mode == EXACT || mode == SORTED) {
switch (dataType) {
case ASCII:
case DICTIONARY:
| | | | | | 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 |
patObj = objv[objc - 1];
patternBytes = NULL;
if (mode == EXACT || mode == SORTED) {
switch (dataType) {
case ASCII:
case DICTIONARY:
patternBytes = TclGetStringFromObj(patObj, &length);
break;
case INTEGER:
result = TclGetWideIntFromObj(interp, patObj, &patWide);
if (result != TCL_OK) {
goto done;
}
/*
* List representation might have been shimmered; restore it. [Bug
* 1844789]
*/
TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
goto done;
}
/*
* List representation might have been shimmered; restore it. [Bug
* 1844789]
*/
TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
patternBytes = TclGetStringFromObj(patObj, &length);
}
/*
* Set default index value to -1, indicating failure; if we find the item
* in the course of our search, index will be set to the correct value.
*/
|
| ︙ | ︙ | |||
3885 3886 3887 3888 3889 3890 3891 |
}
switch (mode) {
case SORTED:
case EXACT:
switch (dataType) {
case ASCII:
| | | 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 |
}
switch (mode) {
case SORTED:
case EXACT:
switch (dataType) {
case ASCII:
bytes = TclGetStringFromObj(itemPtr, &elemLen);
if (length == elemLen) {
/*
* This split allows for more optimal compilation of
* memcmp/strcasecmp.
*/
if (noCase) {
|
| ︙ | ︙ | |||
3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 |
*/
if (returnSubindices && (sortInfo.indexc != 0)) {
Tcl_BounceRefCount(itemPtr);
itemPtr = SelectObjFromSublist(listv[i+groupOffset],
&sortInfo);
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else if (groupSize > 1) {
Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
groupSize, &listv[i]);
} else {
Tcl_BounceRefCount(itemPtr);
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
| > > > > | 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 |
*/
if (returnSubindices && (sortInfo.indexc != 0)) {
Tcl_BounceRefCount(itemPtr);
itemPtr = SelectObjFromSublist(listv[i+groupOffset],
&sortInfo);
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else if (returnSubindices && (sortInfo.indexc == 0) && (groupSize > 1)) {
Tcl_BounceRefCount(itemPtr);
itemPtr = listv[i + groupOffset];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else if (groupSize > 1) {
Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
groupSize, &listv[i]);
} else {
Tcl_BounceRefCount(itemPtr);
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
|
| ︙ | ︙ | |||
4072 4073 4074 4075 4076 4077 4078 | * Return Value * 0 - failure, unexpected value * 1 - value is a number * 2 - value is an operand keyword * 3 - value is a by keyword * * The decoded value will be assigned to the appropriate | | > | > | > | > > | | | < > > > | > | > | | < < | < | | < | < < < > | < < < < | | < < < < < < | < | < < | > > > > | | > | < | | < < | | | < < < < | < | < | 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 |
* Return Value
* 0 - failure, unexpected value
* 1 - value is a number
* 2 - value is an operand keyword
* 3 - value is a by keyword
*
* The decoded value will be assigned to the appropriate
* pointer, numValuePtr reference count is incremented.
*/
static SequenceDecoded
SequenceIdentifyArgument(
Tcl_Interp *interp, /* for error reporting */
Tcl_Obj *argPtr, /* Argument to decode */
int allowedArgs, /* Flags if keyword or numeric allowed. */
Tcl_Obj **numValuePtr, /* Return numeric value */
int *keywordIndexPtr) /* Return keyword enum */
{
int result = TCL_ERROR;
SequenceOperators opmode;
void *internalPtr;
if (allowedArgs & NumericArg) {
/* speed-up a bit (and avoid shimmer for compiled expressions) */
if (TclHasInternalRep(argPtr, &tclExprCodeType)) {
goto doExpr;
}
result = Tcl_GetNumberFromObj(NULL, argPtr, &internalPtr, keywordIndexPtr);
if (result == TCL_OK) {
*numValuePtr = argPtr;
Tcl_IncrRefCount(argPtr);
return NumericArg;
}
}
if (allowedArgs & RangeKeywordArg) {
result = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations,
"range operation", 0, &opmode);
}
if (result == TCL_OK) {
if (allowedArgs & LastArg) {
/* keyword found, but no followed number */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing \"%s\" value.", TclGetString(argPtr)));
return ErrArg;
}
*keywordIndexPtr = opmode;
return RangeKeywordArg;
} else {
Tcl_Obj *exprValueObj;
if (!(allowedArgs & NumericArg)) {
return NoneArg;
}
doExpr:
/* Check for an index expression */
if (Tcl_ExprObj(interp, argPtr, &exprValueObj) != TCL_OK) {
return ErrArg;
}
int keyword;
/* Determine if result of expression is double or int */
if (Tcl_GetNumberFromObj(interp, exprValueObj, &internalPtr,
&keyword) != TCL_OK
) {
return ErrArg;
}
*numValuePtr = exprValueObj; /* incremented in Tcl_ExprObj */
*keywordIndexPtr = keyword; /* type of expression result */
return NumericArg;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_LseqObjCmd --
*
|
| ︙ | ︙ | |||
4197 4198 4199 4200 4201 4202 4203 |
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *elementCount = NULL;
Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
Tcl_WideInt values[5];
Tcl_Obj *numValues[5];
Tcl_Obj *numberObj;
| | > > | | | | | > | | | | > > | < | | | | | | | | | > | > > > > > | < | | > > | | | | < < < | < < | | | | | < | | < < < < < < < > > > > | 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 |
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *elementCount = NULL;
Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
Tcl_WideInt values[5];
Tcl_Obj *numValues[5];
Tcl_Obj *numberObj;
int status = TCL_ERROR, keyword, allowedArgs = NumericArg;
int useDoubles = 0;
int remNums = 3;
Tcl_Obj *arithSeriesPtr;
SequenceOperators opmode;
SequenceDecoded decoded;
int i, arg_key = 0, value_i = 0;
/* Default constants */
#define zero ((Interp *)interp)->execEnvPtr->constants[0];
#define one ((Interp *)interp)->execEnvPtr->constants[1];
/*
* Create a decoding key by looping through the arguments and identify
* what kind of argument each one is. Encode each argument as a decimal
* digit.
*/
if (objc > 6) {
/* Too many arguments */
goto syntax;
}
for (i = 1; i < objc; i++) {
arg_key = (arg_key * 10);
numValues[value_i] = NULL;
decoded = SequenceIdentifyArgument(interp, objv[i],
allowedArgs | (i == objc-1 ? LastArg : 0),
&numberObj, &keyword);
switch (decoded) {
case NoneArg:
/*
* Unrecognizable argument
* Reproduce operation error message
*/
status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations,
"operation", 0, &opmode);
goto done;
case NumericArg:
remNums--;
arg_key += NumericArg;
allowedArgs = RangeKeywordArg;
/* if last number but 2 arguments remain, next is not numeric */
if ((remNums != 1) || ((objc-1-i) != 2)) {
allowedArgs |= NumericArg;
}
numValues[value_i] = numberObj;
values[value_i] = keyword; /* TCL_NUMBER_* */
if ((keyword == TCL_NUMBER_DOUBLE || keyword == TCL_NUMBER_NAN)) {
useDoubles++;
}
value_i++;
break;
case RangeKeywordArg:
arg_key += RangeKeywordArg;
allowedArgs = NumericArg; /* after keyword always numeric only */
values[value_i] = keyword; /* SequenceOperators */
value_i++;
break;
default: /* Error state */
status = TCL_ERROR;
goto done;
}
}
/*
* The key encoding defines a valid set of arguments, or indicates an
* error condition; process the values accordningly.
*/
switch (arg_key) {
/* lseq n */
case 1:
start = zero;
elementCount = numValues[0];
end = NULL;
step = one;
useDoubles = 0; /* Can only have Integer value. If a fractional value
* is given, this will fail later. In other words,
* "3.0" is allowed and used as Integer, but "3.1"
* will be flagged as an error. (bug f4a4bd7f1070) */
break;
/* lseq n n */
case 11:
start = numValues[0];
end = numValues[1];
break;
|
| ︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | break; case LSEQ_COUNT: start = numValues[0]; elementCount = numValues[2]; step = one; break; default: | | | 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 |
break;
case LSEQ_COUNT:
start = numValues[0];
elementCount = numValues[2];
step = one;
break;
default:
goto syntax;
}
break;
/* lseq n 'to' n n */
/* lseq n 'count' n n */
case 1211:
opmode = (SequenceOperators)values[1];
|
| ︙ | ︙ | |||
4335 4336 4337 4338 4339 4340 4341 | case LSEQ_COUNT: start = numValues[0]; elementCount = numValues[2]; step = numValues[3]; break; case LSEQ_BY: /* Error case */ | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > | > > | | > > | > | > | | > | > > > | 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 |
case LSEQ_COUNT:
start = numValues[0];
elementCount = numValues[2];
step = numValues[3];
break;
case LSEQ_BY:
/* Error case */
goto syntax;
break;
default:
goto syntax;
break;
}
break;
/* lseq n n 'by' n */
case 1121:
start = numValues[0];
end = numValues[1];
opmode = (SequenceOperators)values[2];
switch (opmode) {
case LSEQ_BY:
step = numValues[3];
break;
case LSEQ_DOTS:
case LSEQ_TO:
case LSEQ_COUNT:
default:
goto syntax;
break;
}
break;
/* lseq n 'to' n 'by' n */
/* lseq n 'count' n 'by' n */
case 12121:
start = numValues[0];
opmode = (SequenceOperators)values[3];
switch (opmode) {
case LSEQ_BY:
step = numValues[4];
break;
default:
goto syntax;
break;
}
opmode = (SequenceOperators)values[1];
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
start = numValues[0];
end = numValues[2];
break;
case LSEQ_COUNT:
start = numValues[0];
elementCount = numValues[2];
break;
default:
goto syntax;
break;
}
break;
/* All other argument errors */
default:
syntax:
Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
goto done;
break;
}
/* Count needs to be integer, so try to convert if possible */
if (elementCount && TclHasInternalRep(elementCount, &tclDoubleType)) {
double d = elementCount->internalRep.doubleValue;
/* Don't consider Count type to indicate using double values in seqence */
useDoubles -= (useDoubles > 0) ? 1 : 0;
if (!isinf(d) && !isnan(d) && floor(d) == d) {
if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) {
mp_int big;
if (Tcl_InitBignumFromDouble(NULL, d, &big) == TCL_OK) {
elementCount = Tcl_NewBignumObj(&big);
keyword = TCL_NUMBER_INT;
}
/* Infinity, don't convert, let fail later */
} else {
elementCount = Tcl_NewWideIntObj((Tcl_WideInt)d);
keyword = TCL_NUMBER_INT;
}
}
}
/*
* Success! Now lets create the series object.
*/
arithSeriesPtr = TclNewArithSeriesObj(interp,
useDoubles, start, end, step, elementCount);
status = TCL_ERROR;
if (arithSeriesPtr) {
status = TCL_OK;
Tcl_SetObjResult(interp, arithSeriesPtr);
}
done:
// Free number arguments.
while (--value_i>=0) {
if (numValues[value_i]) {
if (elementCount == numValues[value_i]) {
elementCount = NULL;
}
Tcl_DecrRefCount(numValues[value_i]);
}
}
if (elementCount) {
Tcl_DecrRefCount(elementCount);
}
/* Undef constants */
#undef zero
#undef one
return status;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4629 4630 4631 4632 4633 4634 4635 |
sortInfo.sortMode = SORTMODE_ASCII;
break;
case LSORT_COMMAND:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
"by comparison command", -1));
| | | 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 |
sortInfo.sortMode = SORTMODE_ASCII;
break;
case LSORT_COMMAND:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
"by comparison command", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
sortInfo.sortMode = SORTMODE_COMMAND;
cmdPtr = objv[i+1];
i++;
break;
|
| ︙ | ︙ | |||
4654 4655 4656 4657 4658 4659 4660 |
Tcl_Size sortindex;
Tcl_Obj **indexv;
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
| | | | 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 |
Tcl_Size sortindex;
Tcl_Obj **indexv;
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
if (TclListObjGetElements(interp, objv[i+1], &sortindex,
&indexv) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
/*
* Check each of the indices for syntactic correctness. Note that
|
| ︙ | ︙ | |||
4681 4682 4683 4684 4685 4686 4687 |
int result = TclIndexEncode(interp, indexv[j],
TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range",
TclGetString(indexv[j])));
| | < | 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 |
int result = TclIndexEncode(interp, indexv[j],
TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range",
TclGetString(indexv[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (char *)NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %" TCL_Z_MODIFIER "u)", j));
sortInfo.resultCode = TCL_ERROR;
goto done;
|
| ︙ | ︙ | |||
4716 4717 4718 4719 4720 4721 4722 |
indices = 1;
break;
case LSORT_STRIDE:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
| | | | 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 |
indices = 1;
break;
case LSORT_STRIDE:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)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",
"BADSTRIDE", (char *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
groupSize = wide;
group = 1;
i++;
break;
|
| ︙ | ︙ | |||
4751 4752 4753 4754 4755 4756 4757 |
* expected here; the values are all of the right type or convertible to
* it.
*/
if (indexPtr) {
Tcl_Obj **indexv;
| | | 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 |
* expected here; the values are all of the right type or convertible to
* it.
*/
if (indexPtr) {
Tcl_Obj **indexv;
TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
switch (sortInfo.indexc) {
case 0:
sortInfo.indexv = NULL;
break;
case 1:
sortInfo.indexv = &sortInfo.singleIndex;
break;
|
| ︙ | ︙ | |||
4813 4814 4815 4816 4817 4818 4819 |
sortInfo.compareCmdPtr = newCommandPtr;
}
if (TclObjTypeHasProc(objv[1], getElementsProc)) {
sortInfo.resultCode =
TclObjTypeGetElements(interp, listObj, &length, &listObjPtrs);
} else {
| | | | | 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 |
sortInfo.compareCmdPtr = newCommandPtr;
}
if (TclObjTypeHasProc(objv[1], getElementsProc)) {
sortInfo.resultCode =
TclObjTypeGetElements(interp, listObj, &length, &listObjPtrs);
} else {
sortInfo.resultCode = TclListObjGetElements(interp, listObj,
&length, &listObjPtrs);
}
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
/*
* Check for sanity when grouping elements of the overall list together
* because of the -stride option. [TIP #326]
*/
if (group) {
if (length % groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list size must be a multiple of the stride length",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
(char *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
length = length / groupSize;
if (sortInfo.indexc > 0) {
/*
* Use the first value in the list supplied to -index as the
* offset of the element within each group by which to sort.
*/
groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
if (groupOffset < 0 || groupOffset >= groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"when used with \"-stride\", the leading \"-index\""
" value must be within the group", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
"BADINDEX", (char *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
if (sortInfo.indexc == 1) {
sortInfo.indexc = 0;
sortInfo.indexv = NULL;
} else {
|
| ︙ | ︙ | |||
4910 4911 4912 4913 4914 4915 4916 |
elementArray = (SortElement *)Tcl_Alloc(elmArrSize);
} else {
elementArray = (SortElement *)malloc(elmArrSize);
}
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no enough memory to proccess sort of %" TCL_Z_MODIFIER "u items", length));
| | | 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 |
elementArray = (SortElement *)Tcl_Alloc(elmArrSize);
} else {
elementArray = (SortElement *)malloc(elmArrSize);
}
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no enough memory to proccess sort of %" TCL_Z_MODIFIER "u items", length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
|
| ︙ | ︙ | |||
4946 4947 4948 4949 4950 4951 4952 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
elementArray[i].collationKey.wideValue = a;
} else if (sortMode == SORTMODE_REAL) {
double a;
| | < | 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
elementArray[i].collationKey.wideValue = a;
} else if (sortMode == SORTMODE_REAL) {
double a;
if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
elementArray[i].collationKey.doubleValue = a;
} else {
elementArray[i].collationKey.objValuePtr = indexPtr;
}
|
| ︙ | ︙ | |||
5108 5109 5110 5111 5112 5113 5114 |
}
/*
* TODO - refactor the index extraction into a common function shared
* by Tcl_{Lrange,Lreplace,Ledit}ObjCmd
*/
| | | 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 |
}
/*
* TODO - refactor the index extraction into a common function shared
* by Tcl_{Lrange,Lreplace,Ledit}ObjCmd
*/
result = TclListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first);
if (result != TCL_OK) {
return result;
|
| ︙ | ︙ | |||
5332 5333 5334 5335 5336 5337 5338 | * Once an error has occurred, skip any future comparisons so as * to preserve the error message in sortInterp->result. */ return 0; } | < | | | | 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 |
* Once an error has occurred, skip any future comparisons so as
* to preserve the error message in sortInterp->result.
*/
return 0;
}
objPtr1 = elemPtr1->collationKey.objValuePtr;
objPtr2 = elemPtr2->collationKey.objValuePtr;
paramObjv[0] = objPtr1;
paramObjv[1] = objPtr2;
/*
* We made space in the command list for the two things to compare.
* Replace them and evaluate the result.
*/
TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
2, 2, paramObjv);
TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
&objc, &objv);
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
if (infoPtr->resultCode != TCL_OK) {
Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)");
return 0;
}
/*
* Parse the result of the command.
*/
if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
"-compare command returned non-integer result", -1));
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
"COMPARISONFAILED", (char *)NULL);
infoPtr->resultCode = TCL_ERROR;
return 0;
}
}
if (!infoPtr->isIncreasing) {
order = -order;
}
|
| ︙ | ︙ | |||
5410 5411 5412 5413 5414 5415 5416 |
const char *left, const char *right) /* The strings to compare. */
{
int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower;
int diff, zeros;
int secondaryDiff = 0;
while (1) {
| | | 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 |
const char *left, const char *right) /* The strings to compare. */
{
int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower;
int diff, zeros;
int secondaryDiff = 0;
while (1) {
if (isdigit(UCHAR(*right)) /* INTL: digit */
&& isdigit(UCHAR(*left))) { /* INTL: digit */
/*
* There are decimal numbers embedded in the two strings. Compare
* them as numbers, rather than strings. If one number has more
* leading zeros than the other, the number with more leading
* zeros sorts later, but only as a secondary choice.
*/
|
| ︙ | ︙ | |||
5474 5475 5476 5477 5478 5479 5480 |
/*
* Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
if ((*left != '\0') && (*right != '\0')) {
| | | | 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 |
/*
* Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
if ((*left != '\0') && (*right != '\0')) {
left += TclUtfToUniChar(left, &uniLeft);
right += TclUtfToUniChar(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
* dictionary sorts are case-insensitive. Covert to lower, not
* upper, so chars between Z and a will sort before A (where most
* other interesting punctuations occur).
*/
|
| ︙ | ︙ | |||
5558 5559 5560 5561 5562 5563 5564 |
*/
for (i=0 ; i<infoPtr->indexc ; i++) {
Tcl_Size listLen;
int index;
Tcl_Obj *currentObj, *lastObj=NULL;
| | | 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 |
*/
for (i=0 ; i<infoPtr->indexc ; i++) {
Tcl_Size listLen;
int index;
Tcl_Obj *currentObj, *lastObj=NULL;
if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
index = TclIndexDecode(infoPtr->indexv[i], listLen - 1);
if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
|
| ︙ | ︙ | |||
5582 5583 5584 5585 5586 5587 5588 |
index, TclGetString(objPtr)));
} else {
Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
"element %d missing from sublist \"%s\"",
index, TclGetString(objPtr)));
}
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
| | | 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 |
index, TclGetString(objPtr)));
} else {
Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
"element %d missing from sublist \"%s\"",
index, TclGetString(objPtr)));
}
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
"INDEXFAILED", (char *)NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
objPtr = currentObj;
Tcl_BounceRefCount(lastObj);
lastObj = currentObj;
}
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); static Tcl_NRPostProc SwitchPostProc; static Tcl_NRPostProc TryPostBody; static Tcl_NRPostProc TryPostFinal; static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); | | | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); static Tcl_NRPostProc SwitchPostProc; static Tcl_NRPostProc TryPostBody; static Tcl_NRPostProc TryPostFinal; static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); static int StringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, Tcl_Size *reqlength); /* * Default set of characters to trim in [string trim] and friends. This is a * UTF-8 literal string containing all Unicode space characters [TIP #413] */ const char tclDefaultTrimSet[] = |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
* no-no.
*/
if (doinline && ((objc - 2) != 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"regexp match variables not allowed when using -inline", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP",
| | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
* no-no.
*/
if (doinline && ((objc - 2) != 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"regexp match variables not allowed when using -inline", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP",
"MIX_VAR_INLINE", (char *)NULL);
goto optionError;
}
/*
* Handle the odd about case separately.
*/
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 | /* * In command-prefix mode, we require that the third non-option * argument be a list, so we enforce that here. Afterwards, we fetch * the RE compilation again in case objv[0] and objv[2] are the same * object. (If they aren't, that's cheap to do.) */ | | | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
/*
* In command-prefix mode, we require that the third non-option
* argument be a list, so we enforce that here. Afterwards, we fetch
* the RE compilation again in case objv[0] and objv[2] are the same
* object. (If they aren't, that's cheap to do.)
*/
if (TclListObjLength(interp, objv[2], &numParts) != TCL_OK) {
return TCL_ERROR;
}
if (numParts < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command prefix must be a list of at least one element",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB",
"CMDEMPTY", (char *)NULL);
return TCL_ERROR;
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
}
/*
* Make sure to avoid problems where the objects are shared. This can
|
| ︙ | ︙ | |||
775 776 777 778 779 780 781 |
* everything is passed through Tcl_EvalObjv, as that's much faster.
*/
if (command) {
Tcl_Obj **args = NULL, **parts;
Tcl_Size numArgs;
| | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
* everything is passed through Tcl_EvalObjv, as that's much faster.
*/
if (command) {
Tcl_Obj **args = NULL, **parts;
Tcl_Size numArgs;
TclListObjGetElements(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs);
memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);
for (idx = 0 ; idx <= info.nsubs ; idx++) {
subStart = info.matches[idx].start;
subEnd = info.matches[idx].end;
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
const char *encodingName = NULL;
Tcl_Obj *fileName;
int result;
void **pkgFiles = NULL;
void *names = NULL;
if (objc < 2 || objc > 4) {
| | | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 |
const char *encodingName = NULL;
Tcl_Obj *fileName;
int result;
void **pkgFiles = NULL;
void *names = NULL;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-encoding encoding? fileName");
return TCL_ERROR;
}
fileName = objv[objc-1];
if (objc == 4) {
static const char *const options[] = {
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 |
Tcl_Size splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
| | | | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 |
Tcl_Size splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
splitChars = TclGetStringFromObj(objv[2], &splitCharLen);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
stringPtr = TclGetStringFromObj(objv[1], &stringLen);
end = stringPtr + stringLen;
TclNewObj(listPtr);
if (stringLen == 0) {
/*
* Do nothing.
*/
|
| ︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
| | | 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
len = TclUtfToUniChar(stringPtr, &ch);
hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
/*
* Don't need to fiddle with refcount...
*/
|
| ︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 |
* Normal case: split on any of a given set of characters. Discard
* instances of the split characters.
*/
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
| | | | 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
* Normal case: split on any of a given set of characters. Discard
* instances of the split characters.
*/
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
len = TclUtfToUniChar(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUniChar(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = stringPtr + len;
break;
}
}
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
case STR_IS_TRUE:
case STR_IS_FALSE:
if (!TclHasInternalRep(objPtr, &tclBooleanType)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
| | | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 |
case STR_IS_TRUE:
case STR_IS_FALSE:
if (!TclHasInternalRep(objPtr, &tclBooleanType)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
string1 = TclGetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
} else if ((objPtr->internalRep.wideValue != 0)
? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) {
result = 0;
}
break;
|
| ︙ | ︙ | |||
1640 1641 1642 1643 1644 1645 1646 | * SetDictFromAny(). */ const char *elemStart, *nextElem; Tcl_Size lenRemain, elemSize; const char *p; | | | 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 |
* SetDictFromAny().
*/
const char *elemStart, *nextElem;
Tcl_Size lenRemain, elemSize;
const char *p;
string1 = TclGetStringFromObj(objPtr, &length1);
end = string1 + length1;
failat = -1;
for (p=string1, lenRemain=length1; lenRemain > 0;
p=nextElem, lenRemain=end-nextElem) {
if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
&elemStart, &nextElem, &elemSize, NULL)) {
Tcl_Obj *tmpStr;
|
| ︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 |
break;
case STR_IS_DOUBLE: {
if (TclHasInternalRep(objPtr, &tclDoubleType) ||
TclHasInternalRep(objPtr, &tclIntType) ||
TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
| | | 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 |
break;
case STR_IS_DOUBLE: {
if (TclHasInternalRep(objPtr, &tclDoubleType) ||
TclHasInternalRep(objPtr, &tclIntType) ||
TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
|
| ︙ | ︙ | |||
1710 1711 1712 1713 1714 1715 1716 |
break;
case STR_IS_INT:
case STR_IS_ENTIER:
if (TclHasInternalRep(objPtr, &tclIntType) ||
TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
| | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 |
break;
case STR_IS_INT:
case STR_IS_ENTIER:
if (TclHasInternalRep(objPtr, &tclIntType) ||
TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 |
}
break;
case STR_IS_WIDE:
if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
| | | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
}
break;
case STR_IS_WIDE:
if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
result = 0;
|
| ︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
| | | | 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 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
if (TCL_OK == TclListObjLength(NULL, objPtr, &length3)) {
break;
}
if (failVarObj != NULL) {
/*
* Need to figure out where the list parsing failed, which is
* fairly expensive. This is adapted from the core of
* SetListFromAny().
*/
const char *elemStart, *nextElem;
Tcl_Size lenRemain;
Tcl_Size elemSize;
const char *p;
string1 = TclGetStringFromObj(objPtr, &length1);
end = string1 + length1;
failat = -1;
for (p=string1, lenRemain=length1; lenRemain > 0;
p=nextElem, lenRemain=end-nextElem) {
if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
&elemStart, &nextElem, &elemSize, NULL)) {
Tcl_Obj *tmpStr;
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 |
break;
case STR_IS_XDIGIT:
chcomp = UniCharIsHexDigit;
break;
}
if (chcomp != NULL) {
| | | | 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 |
break;
case STR_IS_XDIGIT:
chcomp = UniCharIsHexDigit;
break;
}
if (chcomp != NULL) {
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
int ucs4;
length2 = TclUtfToUniChar(string1, &ucs4);
if (!chcomp(ucs4)) {
result = 0;
break;
}
}
}
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 4) {
| | | | 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 4) {
const char *string = TclGetStringFromObj(objv[1], &length2);
if ((length2 > 1) &&
strncmp(string, "-nocase", length2) == 0) {
nocase = 1;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, (char *)NULL);
return TCL_ERROR;
}
}
/*
* This test is tricky, but has to be that way or you get other strange
* inconsistencies (see test string-10.20.1 for illustration why!)
|
| ︙ | ︙ | |||
2019 2020 2021 2022 2023 2024 2025 |
mapElemv+1, &done);
for (index=2 ; index<mapElemc ; index+=2) {
Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
}
Tcl_DictObjDone(&search);
} else {
Tcl_Size i;
| | | | 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 |
mapElemv+1, &done);
for (index=2 ; index<mapElemc ; index+=2) {
Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
}
Tcl_DictObjDone(&search);
} else {
Tcl_Size i;
if (TclListObjGetElements(interp, objv[objc-2], &i,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
mapElemc = i;
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given.
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
} else if (mapElemc & 1) {
/*
* The charMap must be an even number of key/value items.
*/
Tcl_SetObjResult(interp,
Tcl_NewStringObj("char map list unbalanced", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP",
"UNBALANCED", (char *)NULL);
return TCL_ERROR;
}
}
/*
* Take a copy of the source string object if it is the same as the map
* string to cut out nasty sharing crashes. [Bug 1018562]
|
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Size length;
| | < | | | 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Size length;
const char *string = TclGetStringFromObj(objv[1], &length);
if ((length > 1) && strncmp(string, "-nocase", length) == 0) {
nocase = TCL_MATCH_NOCASE;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, (char *)NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
TclStringMatchObj(objv[objc-1], objv[objc-2], nocase)));
return TCL_OK;
}
|
| ︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
| | | | 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 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
string2 = TclGetStringFromObj(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, (char *)NULL);
return TCL_ERROR;
}
}
/*
* From now on, we only access the two objects at the end of the argument
* array.
|
| ︙ | ︙ | |||
2749 2750 2751 2752 2753 2754 2755 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
| | | | | | 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
string = TclGetStringFromObj(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, (char *)NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2890 2891 2892 2893 2894 2895 2896 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
| | | 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToLower(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
2925 2926 2927 2928 2929 2930 2931 |
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
| | | 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 |
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
length2 = Tcl_UtfToLower(string2);
Tcl_SetObjLength(resultPtr, length2 + (start - string1));
|
| ︙ | ︙ | |||
2975 2976 2977 2978 2979 2980 2981 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
| | | 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
3010 3011 3012 3013 3014 3015 3016 |
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
| | | 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 |
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
length2 = Tcl_UtfToUpper(string2);
Tcl_SetObjLength(resultPtr, length2 + (start - string1));
|
| ︙ | ︙ | |||
3060 3061 3062 3063 3064 3065 3066 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
| | | 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
3095 3096 3097 3098 3099 3100 3101 |
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
| | | 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 |
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
length2 = Tcl_UtfToTitle(string2);
Tcl_SetObjLength(resultPtr, length2 + (start - string1));
|
| ︙ | ︙ | |||
3140 3141 3142 3143 3144 3145 3146 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
Tcl_Size triml, trimr, length1, length2;
if (objc == 3) {
| | | | 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
Tcl_Size triml, trimr, length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
triml = TclTrim(string1, length1, string2, length2, &trimr);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
return TCL_OK;
}
|
| ︙ | ︙ | |||
3188 3189 3190 3191 3192 3193 3194 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
| | | | 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
trim = TclTrimLeft(string1, length1, string2, length2);
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim));
return TCL_OK;
}
|
| ︙ | ︙ | |||
3235 3236 3237 3238 3239 3240 3241 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
| | | | 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
trim = TclTrimRight(string1, length1, string2, length2);
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim));
return TCL_OK;
}
|
| ︙ | ︙ | |||
3501 3502 3503 3504 3505 3506 3507 | * Mode already set via -exact, -glob, or -regexp. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": %s option already found", TclGetString(objv[i]), options[mode])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", | | | | | | | 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 |
* Mode already set via -exact, -glob, or -regexp.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": %s option already found",
TclGetString(objv[i]), options[mode]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"DOUBLEOPT", (char *)NULL);
return TCL_ERROR;
}
foundmode = 1;
mode = index;
break;
/*
* Check for TIP#75 options specifying the variables to write
* regexp information into.
*/
case OPT_INDEXV:
i++;
if (i >= objc-2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing variable name argument to %s option",
"-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", (char *)NULL);
return TCL_ERROR;
}
indexVarObj = objv[i];
numMatchesSaved = -1;
break;
case OPT_MATCHV:
i++;
if (i >= objc-2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing variable name argument to %s option",
"-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", (char *)NULL);
return TCL_ERROR;
}
matchVarObj = objv[i];
numMatchesSaved = -1;
break;
}
}
finishedOptions:
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-option ...? string ?pattern body ...? ?default body?");
return TCL_ERROR;
}
if (indexVarObj != NULL && mode != OPT_REGEXP) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s option requires -regexp option", "-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", (char *)NULL);
return TCL_ERROR;
}
if (matchVarObj != NULL && mode != OPT_REGEXP) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s option requires -regexp option", "-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", (char *)NULL);
return TCL_ERROR;
}
stringObj = objv[i];
objc -= i + 1;
objv += i + 1;
bidx = i + 1; /* First after the match string. */
|
| ︙ | ︙ | |||
3583 3584 3585 3586 3587 3588 3589 |
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
Tcl_Size listc;
blist = objv[0];
| | | | | | | | 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 |
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
Tcl_Size listc;
blist = objv[0];
if (TclListObjLength(interp, objv[0], &listc) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
if (listc < 1 || listc > INT_MAX) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
"?-option ...? string {?pattern body ...? ?default body?}");
return TCL_ERROR;
}
if (TclListObjGetElements(interp, objv[0], &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
objc = listc;
objv = listv;
splitObjs = 1;
}
/*
* Complain if there is an odd number of words in the list of patterns and
* bodies.
*/
if (objc % 2) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"extra switch pattern with no body", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
(char *)NULL);
/*
* Check if this can be due to a badly placed comment in the switch
* block.
*
* The following is an heuristic to detect the infamous "comment in
* switch" error: just check if a pattern begins with '#'.
*/
if (splitObjs) {
for (i=0 ; i<objc ; i+=2) {
if (TclGetString(objv[i])[0] == '#') {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
", this may be due to a comment incorrectly"
" placed outside of a switch body - see the"
" \"switch\" documentation", -1);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"BADARM", "COMMENT?", (char *)NULL);
break;
}
}
}
return TCL_ERROR;
}
/*
* Complain if the last body is a continuation. Note that this check
* assumes that the list is non-empty!
*/
if (strcmp(TclGetString(objv[objc-1]), "-") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no body specified for pattern \"%s\"",
TclGetString(objv[objc-2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
"FALLTHROUGH", (char *)NULL);
return TCL_ERROR;
}
for (i = 0; i < objc; i += 2) {
/*
* See if the pattern matches the string.
*/
pattern = TclGetStringFromObj(objv[i], &patternLength);
if ((i == objc - 2) && (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
Tcl_Obj *emptyObj = NULL;
/*
* If either indexVarObj or matchVarObj are non-NULL, we're in
|
| ︙ | ︙ | |||
3976 3977 3978 3979 3980 3981 3982 |
return TCL_ERROR;
}
/*
* The type must be a list of at least length 1.
*/
| | | | 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 |
return TCL_ERROR;
}
/*
* The type must be a list of at least length 1.
*/
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
return TCL_ERROR;
} else if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"type must be non-empty list", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
(char *)NULL);
return TCL_ERROR;
}
/*
* Now prepare the result options dictionary. We use the list API as it is
* slightly more convenient.
*/
|
| ︙ | ︙ | |||
4722 4723 4724 4725 4726 4727 4728 |
switch (type) {
case TryFinally: /* finally script */
if (i < objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"finally clause must be last", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
| | | | | | | | | 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 |
switch (type) {
case TryFinally: /* finally script */
if (i < objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"finally clause must be last", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"NONTERMINAL", (char *)NULL);
return TCL_ERROR;
} else if (i == objc-1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args to finally clause: must be"
" \"... finally script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"ARGUMENT", (char *)NULL);
return TCL_ERROR;
}
finallyObj = objv[++i];
break;
case TryOn: /* on code variableList script */
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args to on clause: must be \"... on code"
" variableList script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
"ARGUMENT", (char *)NULL);
return TCL_ERROR;
}
if (TclGetCompletionCodeFromObj(interp, objv[i+1],
&code) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
info[2] = NULL;
goto commonHandler;
case TryTrap: /* trap pattern variableList script */
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args to trap clause: "
"must be \"... trap pattern variableList script\"",
-1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"ARGUMENT", (char *)NULL);
return TCL_ERROR;
}
code = 1;
if (TclListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad prefix '%s': must be a list",
TclGetString(objv[i+1])));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"EXNFORMAT", (char *)NULL);
return TCL_ERROR;
}
info[2] = objv[i+1];
commonHandler:
if (TclListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
info[0] = objv[i]; /* type */
TclNewIntObj(info[1], code); /* returnCode */
if (info[2] == NULL) { /* errorCodePrefix */
|
| ︙ | ︙ | |||
4804 4805 4806 4807 4808 4809 4810 |
}
}
if (bodyShared) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"last non-finally clause must not have a body of \"-\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
| | | 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 |
}
}
if (bodyShared) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"last non-finally clause must not have a body of \"-\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
(char *)NULL);
return TCL_ERROR;
}
if (!haveHandlers) {
Tcl_DecrRefCount(handlersObj);
handlersObj = NULL;
}
|
| ︙ | ︙ | |||
4847 4848 4849 4850 4851 4852 4853 |
int resultCode, /* The result code from the just-evaluated
* script. */
Tcl_Obj *oldOptions, /* The old option dictionary. */
Tcl_Obj *errorInfo) /* An object to append to the errorinfo and
* release, or NULL if nothing is to be added.
* Designed to be used with Tcl_ObjPrintf. */
{
| | < < | < | 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 |
int resultCode, /* The result code from the just-evaluated
* script. */
Tcl_Obj *oldOptions, /* The old option dictionary. */
Tcl_Obj *errorInfo) /* An object to append to the errorinfo and
* release, or NULL if nothing is to be added.
* Designed to be used with Tcl_ObjPrintf. */
{
Tcl_Obj *options;
if (errorInfo != NULL) {
Tcl_AppendObjToErrorInfo(interp, errorInfo);
}
options = Tcl_GetReturnOptions(interp, resultCode);
TclDictPut(interp, options, "-during", oldOptions);
Tcl_IncrRefCount(options);
Tcl_DecrRefCount(oldOptions);
return options;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4928 4929 4930 4931 4932 4933 4934 |
* Handle the results.
*/
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
| | | | < | < | | | | | 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 |
* Handle the results.
*/
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
TclListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
Tcl_Size numElems = 0;
TclListObjGetElements(NULL, handlers[i], &numElems, &info);
if (!found) {
Tcl_GetIntFromObj(NULL, info[1], &code);
if (code != result) {
continue;
}
/*
* When processing an error, we must also perform list-prefix
* matching of the errorcode list. However, if this was an
* 'on' handler, the list that we are matching against will be
* empty.
*/
if (code == TCL_ERROR) {
Tcl_Obj *errcode, **bits1, **bits2;
Tcl_Size len1, len2, j;
TclDictGet(NULL, options, "-errorcode", &errcode);
TclListObjGetElements(NULL, info[2], &len1, &bits1);
if (TclListObjGetElements(NULL, errcode, &len2,
&bits2) != TCL_OK) {
continue;
}
if (len2 < len1) {
continue;
}
for (j=0 ; j<len1 ; j++) {
if (TclStringCmp(bits1[j], bits2[j], 1, 0,
TCL_INDEX_NONE) != 0) {
/*
* Really want 'continue outerloop;', but C does
* not give us that.
*/
goto didNotMatch;
}
|
| ︙ | ︙ | |||
4995 4996 4997 4998 4999 5000 5001 | /* * Bind the variables. We already know this is a list of variable * names, but it might be empty. */ Tcl_ResetResult(interp); result = TCL_ERROR; | | | 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 |
/*
* Bind the variables. We already know this is a list of variable
* names, but it might be empty.
*/
Tcl_ResetResult(interp);
result = TCL_ERROR;
TclListObjLength(NULL, info[3], &numElems);
if (numElems> 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(resultObj);
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
298 299 300 301 302 303 304 |
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
dataTokenPtr = TokenAfter(varTokenPtr);
TclNewObj(literalObj);
isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
isDataValid = (isDataLiteral
| | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
dataTokenPtr = TokenAfter(varTokenPtr);
TclNewObj(literalObj);
isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
isDataValid = (isDataLiteral
&& TclListObjLength(NULL, literalObj, &len) == TCL_OK);
isDataEven = (isDataValid && (len & 1) == 0);
/*
* Special case: literal odd-length argument is always an error.
*/
if (isDataValid && !isDataEven) {
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 | * a non-local variable: upvar from a local one! This consumes the * variable name that was left at stacktop. */ localIndex = TclFindCompiledLocal(varTokenPtr->start, varTokenPtr->size, 1, envPtr); PushStringLiteral(envPtr, "0"); | | | | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
* a non-local variable: upvar from a local one! This consumes the
* variable name that was left at stacktop.
*/
localIndex = TclFindCompiledLocal(varTokenPtr->start,
varTokenPtr->size, 1, envPtr);
PushStringLiteral(envPtr, "0");
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
TclEmitOpcode(INST_POP, envPtr);
}
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
|
| ︙ | ︙ | |||
653 654 655 656 657 658 659 |
/* drop the script */
dropScript = 1;
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
ExceptionRangeEnds(envPtr, range);
| < < | 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 |
/* drop the script */
dropScript = 1;
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
ExceptionRangeEnds(envPtr, range);
/*
* Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
* and jump around the "error case" code.
*/
TclCheckStackDepth(depth+1, envPtr);
PushStringLiteral(envPtr, "0");
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
/*
* Emit the "error case" epilogue. Push the interpreter result and the
* return code.
*/
ExceptionRangeTarget(envPtr, range, catchOffset);
TclSetStackDepth(depth + dropScript, envPtr);
if (dropScript) {
TclEmitOpcode( INST_POP, envPtr);
}
/* Stack at this point is empty */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
/* Stack at this point on both branches: result returnCode */
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
break;
case 2:
/*
* -milliseconds or -microseconds
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD
| | | | | < | 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 |
break;
case 2:
/*
* -milliseconds or -microseconds
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD
|| tokenPtr[1].size < 4
|| tokenPtr[1].size > 13) {
return TCL_ERROR;
} else if (!strncmp(tokenPtr[1].start, "-microseconds",
tokenPtr[1].size)) {
TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr);
break;
} else if (!strncmp(tokenPtr[1].start, "-milliseconds",
tokenPtr[1].size)) {
TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr);
break;
} else {
return TCL_ERROR;
}
default:
return TCL_ERROR;
}
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* TclCompileClockReadingCmd --
*
* Procedure called to compile the "tcl::clock::microseconds",
* "tcl::clock::milliseconds" and "tcl::clock::seconds" commands.
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
}
if (listObj != NULL) {
Tcl_Obj **objs;
const char *bytes;
Tcl_Size len, slen;
| | | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
}
if (listObj != NULL) {
Tcl_Obj **objs;
const char *bytes;
Tcl_Size len, slen;
TclListObjGetElements(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
bytes = TclGetStringFromObj(objPtr, &slen);
PushLiteral(envPtr, bytes, slen);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
/*
* General case: runtime concat.
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
&localIndex, &isScalar, 1);
/*
* If the user specified an array element, we don't bother handling
* that.
*/
if (!isScalar) {
| | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
&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.
*/
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
Tcl_DecrRefCount(valueObj);
}
/*
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
| | | 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 |
Tcl_DecrRefCount(valueObj);
}
/*
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
bytes = TclGetStringFromObj(dictObj, &len);
PushLiteral(envPtr, bytes, len);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
Tcl_DecrRefCount(dictObj);
return TCL_OK;
/*
|
| ︙ | ︙ | |||
2396 2397 2398 2399 2400 2401 2402 |
Tcl_Obj *variables;
TclNewObj(variables);
for (i=0 ; i<duiPtr->length ; i++) {
Tcl_ListObjAppendElement(NULL, variables,
Tcl_NewWideIntObj(duiPtr->varIndices[i]));
}
| < | | 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 |
Tcl_Obj *variables;
TclNewObj(variables);
for (i=0 ; i<duiPtr->length ; i++) {
Tcl_ListObjAppendElement(NULL, variables,
Tcl_NewWideIntObj(duiPtr->varIndices[i]));
}
TclDictPut(NULL, dictObj, "variables", variables);
}
/*
*----------------------------------------------------------------------
*
* TclCompileErrorCmd --
*
|
| ︙ | ︙ | |||
2829 2830 2831 2832 2833 2834 2835 | /* * If the variable list is empty, we can enter an infinite loop when * the interpreted version would not. Take care to ensure this does * not happen. [Bug 1671138] */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || | | < | | 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 |
/*
* If the variable list is empty, we can enter an infinite loop when
* the interpreted version would not. Take care to ensure this does
* not happen. [Bug 1671138]
*/
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != TclListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(varListPtr->varIndexes[0]));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
infoPtr->numLists++;
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
int varIndex;
Tcl_Size length;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
bytes = TclGetStringFromObj(varNameObj, &length);
varIndex = LocalScalar(bytes, length, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
goto done;
}
varListPtr->varIndexes[j] = varIndex;
}
|
| ︙ | ︙ | |||
3136 3137 3138 3139 3140 3141 3142 |
*/
TclNewObj(objPtr);
for (i=0 ; i<infoPtr->numLists ; i++) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewWideIntObj(infoPtr->firstValueTemp + i));
}
| | < | | | | | | 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 |
*/
TclNewObj(objPtr);
for (i=0 ; i<infoPtr->numLists ; i++) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewWideIntObj(infoPtr->firstValueTemp + i));
}
TclDictPut(NULL, dictObj, "data", objPtr);
/*
* Loop counter.
*/
TclDictPut(NULL, dictObj, "loop", Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
*/
TclNewObj(objPtr);
for (i=0 ; i<infoPtr->numLists ; i++) {
TclNewObj(innerPtr);
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
Tcl_ListObjAppendElement(NULL, innerPtr,
Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
}
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
TclDictPut(NULL, dictObj, "assign", objPtr);
}
static void
DisassembleNewForeachInfo(
void *clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
Tcl_Size i, j;
Tcl_Obj *objPtr, *innerPtr;
/*
* Jump offset.
*/
TclDictPut(NULL, dictObj, "jumpOffset",
Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
*/
TclNewObj(objPtr);
for (i=0 ; i<infoPtr->numLists ; i++) {
TclNewObj(innerPtr);
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
Tcl_ListObjAppendElement(NULL, innerPtr,
Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
}
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
TclDictPut(NULL, dictObj, "assign", objPtr);
}
/*
*----------------------------------------------------------------------
*
* TclCompileFormatCmd --
*
|
| ︙ | ︙ | |||
3285 3286 3287 3288 3289 3290 3291 |
}
/*
* Not an error, always a constant result, so just push the result as a
* literal. Job done.
*/
| | | 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 |
}
/*
* Not an error, always a constant result, so just push the result as a
* literal. Job done.
*/
bytes = TclGetStringFromObj(tmpObj, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
checkForStringConcatCase:
/*
* See if we can generate a sequence of things to concatenate. This
|
| ︙ | ︙ | |||
3356 3357 3358 3359 3360 3361 3362 |
* being built. */
for (bytes = start ; *bytes ; bytes++) {
if (*bytes == '%') {
Tcl_AppendToObj(tmpObj, start, bytes - start);
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
| | | 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 |
* being built. */
for (bytes = start ; *bytes ; bytes++) {
if (*bytes == '%') {
Tcl_AppendToObj(tmpObj, start, bytes - start);
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
const char *b = TclGetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
* push it and reset.
*/
if (len > 0) {
|
| ︙ | ︙ | |||
3390 3391 3392 3393 3394 3395 3396 |
}
/*
* Handle the case of a trailing literal.
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
| | | 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 |
}
/*
* Handle the case of a trailing literal.
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
bytes = TclGetStringFromObj(tmpObj, &len);
if (len > 0) {
PushLiteral(envPtr, bytes, len);
i++;
}
Tcl_DecrRefCount(tmpObj);
Tcl_DecrRefCount(formatObj);
|
| ︙ | ︙ | |||
3417 3418 3419 3420 3421 3422 3423 | * * TclLocalScalarFromToken -- * * Get the index into the table of compiled locals that corresponds * to a local scalar variable name. * * Results: | | | | | | 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 | * * TclLocalScalarFromToken -- * * Get the index into the table of compiled locals that corresponds * to a local scalar variable name. * * Results: * Returns the non-negative integer index value into the table of * compiled locals corresponding to a local scalar variable name. * If the arguments passed in do not identify a local scalar variable * then return TCL_INDEX_NONE. * * Side effects: * May add an entry into the table of compiled locals. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
3448 3449 3450 3451 3452 3453 3454 |
size_t
TclLocalScalar(
const char *bytes,
size_t numBytes,
CompileEnv *envPtr)
{
| | > | > | 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 |
size_t
TclLocalScalar(
const char *bytes,
size_t numBytes,
CompileEnv *envPtr)
{
Tcl_Token token[2] = {
{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
{TCL_TOKEN_TEXT, NULL, 0, 0}
};
token[1].start = bytes;
token[1].size = numBytes;
return TclLocalScalarFromToken(token, envPtr);
}
/*
|
| ︙ | ︙ | |||
3566 3567 3568 3569 3570 3571 3572 |
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
&& (*(varTokenPtr[n].start + varTokenPtr[n].size - 1) == ')')) {
/*
* Check for parentheses inside first token.
*/
simpleVarName = 0;
| | | | 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 |
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
&& (*(varTokenPtr[n].start + varTokenPtr[n].size - 1) == ')')) {
/*
* Check for parentheses inside first token.
*/
simpleVarName = 0;
for (p = varTokenPtr[1].start, last = p + varTokenPtr[1].size;
p < last; p++) {
if (*p == '(') {
simpleVarName = 1;
break;
}
}
if (simpleVarName) {
size_t remainingLen;
|
| ︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 |
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
for (p = name, last = p + nameLen-1; p < last; p++) {
| | | 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 |
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
for (p = name, last = p + nameLen-1; p < last; p++) {
if ((p[0] == ':') && (p[1] == ':')) {
hasNsQualifiers = 1;
break;
}
}
/*
* Look up the var name's index in the array of local vars in the proc
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
472 473 474 475 476 477 478 |
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, *incrTokenPtr;
| | > | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 |
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, *incrTokenPtr;
int isScalar, localIndex, haveImmValue;
Tcl_WideInt immValue;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
const char *word = incrTokenPtr[1].start;
size_t numBytes = incrTokenPtr[1].size;
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
| | < > | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
const char *word = incrTokenPtr[1].start;
size_t numBytes = incrTokenPtr[1].size;
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
code = TclGetWideIntFromObj(NULL, intObj, &immValue);
if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
haveImmValue = 1;
}
TclDecrRefCount(intObj);
if (!haveImmValue) {
PushLiteral(envPtr, word, numBytes);
}
} else {
SetLineInformation(2);
CompileTokens(envPtr, incrTokenPtr, interp);
}
|
| ︙ | ︙ | |||
2168 2169 2170 2171 2172 2173 2174 |
}
/*
* Next, higher-level checks. Is the RE a very simple glob? Is the
* replacement "simple"?
*/
| | | 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 |
}
/*
* Next, higher-level checks. Is the RE a very simple glob? Is the
* replacement "simple"?
*/
bytes = TclGetStringFromObj(patternObj, &len);
if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified)
!= TCL_OK || exact || quantified) {
goto done;
}
bytes = Tcl_DStringValue(&pattern);
if (*bytes++ != '*') {
goto done;
|
| ︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 |
/*
* Proved the simplicity constraints! Time to issue the code.
*/
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
| | | 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 |
/*
* Proved the simplicity constraints! Time to issue the code.
*/
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
bytes = TclGetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2);
TclEmitOpcode( INST_STR_MAP, envPtr);
done:
Tcl_DStringFree(&pattern);
if (patternObj) {
|
| ︙ | ︙ | |||
2475 2476 2477 2478 2479 2480 2481 |
void
TclCompileSyntaxError(
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
Tcl_Size numBytes;
| | | 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
void
TclCompileSyntaxError(
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
Tcl_Size numBytes;
const char *bytes = TclGetStringFromObj(msg, &numBytes);
TclErrorStackResetIf(interp, bytes, numBytes);
TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
}
|
| ︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 |
if (lastTokenPtr->type != TCL_TOKEN_TEXT) {
Tcl_DecrRefCount(tailPtr);
return -1;
}
Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size);
}
| | | | 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 |
if (lastTokenPtr->type != TCL_TOKEN_TEXT) {
Tcl_DecrRefCount(tailPtr);
return -1;
}
Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size);
}
tailName = TclGetStringFromObj(tailPtr, &len);
if (len) {
if (*(tailName + len - 1) == ')') {
/*
* Possible array: bail out
*/
Tcl_DecrRefCount(tailPtr);
return -1;
}
/*
* Get the tail: immediately after the last '::'
*/
for (p = tailName + len -1; p > tailName; p--) {
if ((p[0] == ':') && (p[- 1] == ':')) {
p++;
break;
}
}
if (!full && (p == tailName)) {
/*
* No :: in the last component.
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | CompileEnv *envPtr); static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, Tcl_Size numWords, Tcl_Token **bodyToken, | | | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | CompileEnv *envPtr); static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, Tcl_Size numWords, Tcl_Token **bodyToken, Tcl_Size *bodyLines, Tcl_Size **bodyNext); static void IssueSwitchJumpTable(Tcl_Interp *interp, CompileEnv *envPtr, int numWords, Tcl_Token **bodyToken, Tcl_Size *bodyLines, Tcl_Size **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, int *optionVarIndices, Tcl_Token **handlerTokens); static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
#define INVOKE(name) \
TclEmitInvoke(envPtr,INST_##name)
| < | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
#define INVOKE(name) \
TclEmitInvoke(envPtr,INST_##name)
/*
*----------------------------------------------------------------------
*
* TclCompileSetCmd --
*
* Procedure called to compile the "set" command.
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
if (numWords<2) {
PushStringLiteral(envPtr, "");
return TCL_OK;
}
/* General case: issue CONCAT1's (by chunks of 254 if needed), folding
| | | | | 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 |
if (numWords<2) {
PushStringLiteral(envPtr, "");
return TCL_OK;
}
/* General case: issue CONCAT1's (by chunks of 254 if needed), folding
* contiguous constants along the way */
numArgs = 0;
folded = NULL;
wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i = 1; i < numWords; i++) {
TclNewObj(obj);
if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) {
if (folded) {
Tcl_AppendObjToObj(folded, obj);
Tcl_DecrRefCount(obj);
} else {
folded = obj;
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
Tcl_Size len;
const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
CompileWord(envPtr, wordTokenPtr, interp, i);
numArgs ++;
if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */
TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
numArgs = 1; /* concat pushes 1 obj, the result */
}
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
if (folded) {
Tcl_Size len;
const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
if (numArgs > 1) {
|
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
stringTokenPtr = TokenAfter(mapTokenPtr);
TclNewObj(mapObj);
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
| | | | | 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 |
mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
stringTokenPtr = TokenAfter(mapTokenPtr);
TclNewObj(mapObj);
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (TclListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (len != 2) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Now issue the opcodes. Note that in the case that we know that the
* first word is an empty word, we don't issue the map at all. That is the
* correct semantics for mapping.
*/
bytes = TclGetStringFromObj(objv[0], &slen);
if (slen == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, slen);
bytes = TclGetStringFromObj(objv[1], &slen);
PushLiteral(envPtr, bytes, slen);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
}
Tcl_DecrRefCount(mapObj);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2559 2560 2561 2562 2563 2564 2565 |
JumptableInfo *newJtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo));
Tcl_HashEntry *hPtr, *newHPtr;
Tcl_HashSearch search;
int isNew;
Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
| | | 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 |
JumptableInfo *newJtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo));
Tcl_HashEntry *hPtr, *newHPtr;
Tcl_HashSearch search;
int isNew;
Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
}
return newJtPtr;
}
|
| ︙ | ︙ | |||
2625 2626 2627 2628 2629 2630 2631 |
size_t offset;
TclNewObj(mapping);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
| < | | | 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 |
size_t offset;
TclNewObj(mapping);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
TclDictPut(NULL, mapping, keyPtr, Tcl_NewWideIntObj(offset));
}
TclDictPut(NULL, dictObj, "mapping", mapping);
}
/*
*----------------------------------------------------------------------
*
* TclCompileTailcallCmd --
*
|
| ︙ | ︙ | |||
2732 2733 2734 2735 2736 2737 2738 |
if (!codeKnown) {
CompileWord(envPtr, codeToken, interp, 1);
PUSH( "-errorcode");
}
CompileWord(envPtr, msgToken, interp, 2);
codeIsList = codeKnown && (TCL_OK ==
| | | < | | 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 |
if (!codeKnown) {
CompileWord(envPtr, codeToken, interp, 1);
PUSH( "-errorcode");
}
CompileWord(envPtr, msgToken, interp, 2);
codeIsList = codeKnown && (TCL_OK ==
TclListObjLength(interp, objPtr, &len));
codeIsValid = codeIsList && (len != 0);
if (codeIsValid) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
TclDictPut(NULL, dictPtr, "-errorcode", objPtr);
TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr);
}
TclDecrRefCount(objPtr);
/*
* Simpler bytecodes when we detect invalid arguments at compile time.
*/
|
| ︙ | ︙ | |||
2865 2866 2867 2868 2869 2870 2871 | */ matchCodes[i] = TCL_ERROR; tokenPtr = TokenAfter(tokenPtr); TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) | | | 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 |
*/
matchCodes[i] = TCL_ERROR;
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)
|| TclListObjLength(NULL, tmpObj, &objc) != TCL_OK
|| (objc == 0)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL);
matchClauses[i] = tmpObj;
} else if (tokenPtr[1].size == 2
|
| ︙ | ︙ | |||
2908 2909 2910 2911 2912 2913 2914 |
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
| | | | | 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 |
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
Tcl_Size len;
const char *varname = TclGetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
} else {
resultVarIndices[i] = -1;
}
if (objc == 2) {
Tcl_Size len;
const char *varname = TclGetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
} else {
|
| ︙ | ︙ | |||
3123 3124 3125 3126 3127 3128 3129 |
snprintf(buf, sizeof(buf), "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
const char *p;
| | | | 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 |
snprintf(buf, sizeof(buf), "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
const char *p;
TclListObjLength(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
|
| ︙ | ︙ | |||
3335 3336 3337 3338 3339 3340 3341 |
snprintf(buf, sizeof(buf), "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
| | | | 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 |
snprintf(buf, sizeof(buf), "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
TclListObjLength(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
|
| ︙ | ︙ | |||
3674 3675 3676 3677 3678 3679 3680 |
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
Tcl_Size len;
| | | 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 |
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
Tcl_Size len;
bytes = TclGetStringFromObj(leadingWord, &len);
if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags++;
} else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
haveFlags++;
} else {
varCount++;
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
113 114 115 116 117 118 119 | /* * The constant field is a boolean flag marking which subexpressions are * completely known at compile time, and are eligible for computing then * rather than waiting until run time. */ | < < < < < < < < > > > > > > > | | | > > | | | | | | | | < | < | < | < | < | < | < | | | | | < | < | | | | | | < | | | | | | | | < | | < | | | | | | | | | | | < | | | < | | | | | < | > | 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 |
/*
* The constant field is a boolean flag marking which subexpressions are
* completely known at compile time, and are eligible for computing then
* rather than waiting until run time.
*/
/*
* The four category values are LEAF, UNARY, and BINARY, explained below, and
* "uncategorized", which is used either temporarily, until context determines
* which of the other three categories is correct, or for lexemes like
* INVALID, which aren't really lexemes at all, but indicators of a parsing
* error. Note that the codes must be distinct to distinguish categories, but
* need not take the form of a bit array.
*/
enum LexemeTypes {
/*
* Each lexeme belongs to one of four categories, which determine its place
* in the parse tree. We use the two high bits of the (unsigned char) value
* to store a NODE_TYPE code.
*/
NODE_TYPE = 0xC0,
BINARY = 0x40, /* This lexeme is a binary operator. An OpNode
* representing it should go into the parse
* tree, and two operands should be parsed for
* it in the expression. */
UNARY = 0x80, /* This lexeme is a unary operator. An OpNode
* representing it should go into the parse
* tree, and one operand should be parsed for
* it in the expression. */
LEAF = 0xC0 /* This lexeme is a leaf operand in the parse
* tree. No OpNode will be placed in the tree
* for it. Either a literal value will be
* appended to the list of literals in this
* expression, or appropriate Tcl_Tokens will
* be appended in a Tcl_Parse struct to
* represent those leaves that require some
* form of substitution. */
};
enum LexemeCodes {
/* Uncategorized lexemes */
PLUS = 1, /* Ambiguous. Resolves to UNARY_PLUS or
* BINARY_PLUS according to context. */
MINUS = 2, /* Ambiguous. Resolves to UNARY_MINUS or
* BINARY_MINUS according to context. */
BAREWORD = 3, /* Ambiguous. Resolves to BOOL_LIT or to
* FUNCTION or a parse error according to
* context and value. */
INCOMPLETE = 4, /* A parse error. Used only when the single
* "=" is encountered. */
INVALID = 5, /* A parse error. Used when any punctuation
* appears that's not a supported operator. */
COMMENT = 6, /* Comment. Lasts to end of line or end of
* expression, whichever comes first. */
/* Leaf lexemes */
NUMBER = LEAF | 1, /* For literal numbers */
SCRIPT = LEAF | 2, /* Script substitution; [foo] */
BOOL_LIT = LEAF | BAREWORD, /* For literal booleans */
BRACED = LEAF | 4, /* Braced string; {foo bar} */
VARIABLE = LEAF | 5, /* Variable substitution; $x */
QUOTED = LEAF | 6, /* Quoted string; "foo $bar [soom]" */
EMPTY = LEAF | 7, /* Used only for an empty argument list to a
* function. Represents the empty string
* within parens in the expression: rand() */
/* Unary operator lexemes */
UNARY_PLUS = UNARY | PLUS,
UNARY_MINUS = UNARY | MINUS,
FUNCTION = UNARY | BAREWORD,
/* This is a bit of "creative interpretation"
* on the part of the parser. A function call
* is parsed into the parse tree according to
* the perspective that the function name is a
* unary operator and its argument list,
* enclosed in parens, is its operand. The
* additional requirements not implied
* generally by treatment as a unary operator
* -- for example, the requirement that the
* operand be enclosed in parens -- are hard
* coded in the relevant portions of
* ParseExpr(). We trade off the need to
* include such exceptional handling in the
* code against the need we would otherwise
* have for more lexeme categories. */
START = UNARY | 4, /* This lexeme isn't parsed from the
* expression text at all. It represents the
* start of the expression and sits at the
* root of the parse tree where it serves as
* the start/end point of traversals. */
OPEN_PAREN = UNARY | 5, /* Another bit of creative interpretation,
* where we treat "(" as a unary operator with
* the sub-expression between it and its
* matching ")" as its operand. See
* CLOSE_PAREN below. */
NOT = UNARY | 6,
BIT_NOT = UNARY | 7,
/* Binary operator lexemes */
BINARY_PLUS = BINARY | PLUS,
BINARY_MINUS = BINARY | MINUS,
COMMA = BINARY | 3, /* The "," operator is a low precedence binary
* operator that separates the arguments in a
* function call. The additional constraint
* that this operator can only legally appear
* at the right places within a function call
* argument list are hard coded within
* ParseExpr(). */
MULT = BINARY | 4,
DIVIDE = BINARY | 5,
MOD = BINARY | 6,
LESS = BINARY | 7,
GREATER = BINARY | 8,
BIT_AND = BINARY | 9,
BIT_XOR = BINARY | 10,
BIT_OR = BINARY | 11,
QUESTION = BINARY | 12, /* These two lexemes make up the */
COLON = BINARY | 13, /* ternary conditional operator, $x ? $y : $z.
* We treat them as two binary operators to
* avoid another lexeme category, and code the
* additional constraints directly in
* ParseExpr(). For instance, the right
* operand of a "?" operator must be a ":"
* operator. */
LEFT_SHIFT = BINARY | 14,
RIGHT_SHIFT = BINARY | 15,
LEQ = BINARY | 16,
GEQ = BINARY | 17,
EQUAL = BINARY | 18,
NEQ = BINARY | 19,
AND = BINARY | 20,
OR = BINARY | 21,
STREQ = BINARY | 22,
STRNEQ = BINARY | 23,
EXPON = BINARY | 24, /* Unlike the other binary operators, EXPON is
* right associative and this distinction is
* coded directly in ParseExpr(). */
IN_LIST = BINARY | 25,
NOT_IN_LIST = BINARY | 26,
CLOSE_PAREN = BINARY | 27, /* By categorizing the CLOSE_PAREN lexeme as a
* BINARY operator, the normal parsing rules
* for binary operators assure that a close
* paren will not directly follow another
* operator, and the machinery already in
* place to connect operands to operators
* according to precedence performs most of
* the work of matching open and close parens
* for us. In the end though, a close paren is
* not really a binary operator, and some
* special coding in ParseExpr() make sure we
* never put an actual CLOSE_PAREN node in the
* parse tree. The sub-expression between
* parens becomes the single argument of the
* matching OPEN_PAREN unary operator. */
STR_LT = BINARY | 28,
STR_GT = BINARY | 29,
STR_LEQ = BINARY | 30,
STR_GEQ = BINARY | 31,
END = BINARY | 32 /* This lexeme represents the end of the
* string being parsed. Treating it as a
* binary operator follows the same logic as
* the CLOSE_PAREN lexeme and END pairs with
* START, in the same way that CLOSE_PAREN
* pairs with OPEN_PAREN. */
};
/*
* When ParseExpr() builds the parse tree it must choose which operands to
* connect to which operators. This is done according to operator precedence.
* The greater an operator's precedence the greater claim it has to link to an
* available operand. The Precedence enumeration lists the precedence values
* used by Tcl expression operators, from lowest to highest claim. Each
|
| ︙ | ︙ | |||
743 744 745 746 747 748 749 |
* name, and there's no place in the parse tree to store
* it, so we keep a separate list of all the function
* names we've parsed in the order we found them.
*/
Tcl_ListObjAppendElement(NULL, funcList, literal);
} else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
| | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
* name, and there's no place in the parse tree to store
* it, so we keep a separate list of all the function
* names we've parsed in the order we found them.
*/
Tcl_ListObjAppendElement(NULL, funcList, literal);
} else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
lexeme = BOOL_LIT;
} else {
/*
* Tricky case: see test expr-62.10
*/
int scanned2 = scanned;
do {
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 | scanned = 0; insertMark = 1; /* * Free any literal to avoid a memleak. */ | | | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 |
scanned = 0;
insertMark = 1;
/*
* Free any literal to avoid a memleak.
*/
if ((lexeme == NUMBER) || (lexeme == BOOL_LIT)) {
Tcl_DecrRefCount(literal);
}
goto error;
}
switch (lexeme) {
case NUMBER:
case BOOL_LIT:
/*
* TODO: Consider using a dict or hash to collapse all
* duplicate literals into a single representative value.
* (Like what is done with [split $s {}]).
* Pro: ~75% memory saving on expressions like
* {1+1+1+1+1+.....+1} (Convert "pointer + Tcl_Obj" cost
* to "pointer" cost only)
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
numBytes = parsePtr->end - parsePtr->string;
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (parsing expression \"%.*s%s\")",
(numBytes < limit) ? (int)numBytes : (int)limit - 3,
parsePtr->string, (numBytes < limit) ? "" : "..."));
if (errCode) {
Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode,
| | | 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
numBytes = parsePtr->end - parsePtr->string;
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (parsing expression \"%.*s%s\")",
(numBytes < limit) ? (int)numBytes : (int)limit - 3,
parsePtr->string, (numBytes < limit) ? "" : "..."));
if (errCode) {
Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode,
subErrCode, (char *)NULL);
}
}
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 |
static Tcl_Size
ParseLexeme(
const char *start, /* Start of lexeme to parse. */
Tcl_Size numBytes, /* Number of bytes in string. */
unsigned char *lexemePtr, /* Write code of parsed lexeme to this
* storage. */
Tcl_Obj **literalPtr) /* Write corresponding literal value to this
| | | 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 |
static Tcl_Size
ParseLexeme(
const char *start, /* Start of lexeme to parse. */
Tcl_Size numBytes, /* Number of bytes in string. */
unsigned char *lexemePtr, /* Write code of parsed lexeme to this
* storage. */
Tcl_Obj **literalPtr) /* Write corresponding literal value to this
* storage, if non-NULL. */
{
const char *end;
int ch;
Tcl_Obj *literal = NULL;
unsigned char byte;
if (numBytes == 0) {
|
| ︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 |
* Might be inspired by reserved identifier rules in C, which of course
* have no direct relevance here.
*/
if (!TclIsBareword(*start) || *start == '_') {
Tcl_Size scanned;
if (Tcl_UtfCharComplete(start, numBytes)) {
| | | | 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 |
* Might be inspired by reserved identifier rules in C, which of course
* have no direct relevance here.
*/
if (!TclIsBareword(*start) || *start == '_') {
Tcl_Size scanned;
if (Tcl_UtfCharComplete(start, numBytes)) {
scanned = TclUtfToUniChar(start, &ch);
} else {
char utfBytes[8];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
scanned = TclUtfToUniChar(utfBytes, &ch);
}
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
return scanned;
}
end = start;
while (numBytes && TclIsBareword(*end)) {
|
| ︙ | ︙ | |||
2222 2223 2224 2225 2226 2227 2228 | Tcl_Obj *const *litObjv; Tcl_Obj **funcObjv; /* TIP #280 : Track Lines within the expression */ TclAdvanceLines(&envPtr->line, script, script + TclParseAllWhiteSpace(script, numBytes)); | | | | 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 |
Tcl_Obj *const *litObjv;
Tcl_Obj **funcObjv;
/* TIP #280 : Track Lines within the expression */
TclAdvanceLines(&envPtr->line, script,
script + TclParseAllWhiteSpace(script, numBytes));
TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
parsePtr->tokenPtr, envPtr, optimize);
} else {
TclCompileSyntaxError(interp, envPtr);
}
Tcl_FreeParse(parsePtr);
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 |
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
Tcl_Size length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
| | | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 |
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
Tcl_Size length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterLiteral(envPtr,
Tcl_DStringValue(&cmdName),
Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr);
Tcl_DStringFree(&cmdName);
|
| ︙ | ︙ | |||
2504 2505 2506 2507 2508 2509 2510 |
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
Tcl_Size length;
| | | 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 |
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
Tcl_Size length;
const char *bytes = TclGetStringFromObj(literal, &length);
int idx = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
/*
* Would like to do this:
*
|
| ︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 |
* already, then use it to share via the literal table.
*/
if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
Tcl_Size numBytes;
const char *bytes
| | | 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 |
* already, then use it to share via the literal table.
*/
if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
Tcl_Size numBytes;
const char *bytes
= TclGetStringFromObj(objPtr, &numBytes);
idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, idx);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
/*
* Same internalrep surgery as for OT_LITERAL.
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
/* Make array element cease to exist; element is stktop, array name is
* stknext; op1 is 1 for errors on problems, 0 otherwise */
{"unsetStk", 2, -1, 1, {OPERAND_UINT1}},
/* Make general variable cease to exist; unparsed variable name is
* stktop; op1 is 1 for errors on problems, 0 otherwise */
{"dictExpand", 1, -1, 0, {OPERAND_NONE}},
| | | | | | | | | 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 |
/* Make array element cease to exist; element is stktop, array name is
* stknext; op1 is 1 for errors on problems, 0 otherwise */
{"unsetStk", 2, -1, 1, {OPERAND_UINT1}},
/* Make general variable cease to exist; unparsed variable name is
* stktop; op1 is 1 for errors on problems, 0 otherwise */
{"dictExpand", 1, -1, 0, {OPERAND_NONE}},
/* Probe into a dict and extract it (or a subdict of it) into
* variables with matched names. Produces list of keys bound as
* result. Part of [dict with].
* Stack: ... dict path => ... keyList */
{"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}},
/* Map variable contents back into a dictionary in a variable. Part of
* [dict with].
* Stack: ... dictVarName path keyList => ... */
{"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}},
/* Map variable contents back into a dictionary in the local variable
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
{"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* The top op4 words (min 1) are a key path into the dictionary just
* below the keys on the stack, and all those values are replaced by a
* boolean indicating whether it is possible to read out a value from
* that key-path (like [dict exists]).
* Stack: ... dict key1 ... keyN => ... boolean */
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
/* Lappend list to array element.
* Stack: ... arrayName elem list => ... listVarContents */
{"lappendListStk", 1, -1, 0, {OPERAND_NONE}},
/* Lappend list to general variable.
* Stack: ... varName list => ... listVarContents */
{"clockRead", 2, +1, 1, {OPERAND_UINT1}},
| | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 |
/* Lappend list to array element.
* Stack: ... arrayName elem list => ... listVarContents */
{"lappendListStk", 1, -1, 0, {OPERAND_NONE}},
/* Lappend list to general variable.
* Stack: ... varName list => ... listVarContents */
{"clockRead", 2, +1, 1, {OPERAND_UINT1}},
/* Read clock out to the stack. Operand is which clock to read
* 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
* Stack: ... => ... time */
{"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* The top word is the default, the next op4 words (min 1) are a key
* path into the dictionary just below the keys on the stack, and all
* those values are replaced by the value read out of that key-path
|
| ︙ | ︙ | |||
796 797 798 799 800 801 802 |
&tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
}
#endif
| | | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 |
&tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
}
#endif
stringPtr = TclGetStringFromObj(objPtr, &length);
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked, and
* use to initialize the tracking in the compiler. This information was
* stored by TclCompEvalObj and ProcCompileProc.
*/
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/
if (result == TCL_OK) {
(void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv);
| < < | < < < | 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 |
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/
if (result == TCL_OK) {
(void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv);
TclDebugPrintByteCodeObj(objPtr);
}
TclFreeCompileEnv(&compEnv);
return result;
}
/*
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 |
* data with it.
*
* See also tclBasic.c, DeleteInterpProc
*/
if (iPtr) {
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
| | | 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
* data with it.
*
* See also tclBasic.c, DeleteInterpProc
*/
if (iPtr) {
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
codePtr);
if (hePtr) {
ReleaseCmdWordData((ExtCmdLoc *)Tcl_GetHashValue(hePtr));
Tcl_DeleteHashEntry(hePtr);
}
}
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
Tcl_StoreInternalRep(objPtr, &substCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
CompileEnv compEnv;
Tcl_Size numBytes;
| | < < | < < < | 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 |
Tcl_StoreInternalRep(objPtr, &substCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
CompileEnv compEnv;
Tcl_Size numBytes;
const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
/* TODO: Check for more TIP 280 */
TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
TclEmitOpcode(INST_DONE, &compEnv);
codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
SubstFlags(objPtr) = INT2PTR(flags);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
TclDebugPrintByteCodeObj(objPtr);
}
return codePtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1835 1836 1837 1838 1839 1840 1841 |
Tcl_Size length;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
| | | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 |
Tcl_Size length;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = TclGetStringFromObj(cmdObj, &length);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
}
|
| ︙ | ︙ | |||
2178 2179 2180 2181 2182 2183 2184 |
* nested calls of TclCompileScript, considering interp recursionlimit.
* Use factor 5/4 (1.25) to avoid being too mistaken when recognizing the
* limit during "mixed" evaluation and compilation process (nested
* eval+compile) and is good enough for default recursionlimit (1000).
*/
if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 |
* nested calls of TclCompileScript, considering interp recursionlimit.
* Use factor 5/4 (1.25) to avoid being too mistaken when recognizing the
* limit during "mixed" evaluation and compilation process (nested
* eval+compile) and is good enough for default recursionlimit (1000).
*/
if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"too many nested compilations (infinite loop?)", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (char *)NULL);
TclCompileSyntaxError(interp, envPtr);
return;
}
if (numBytes < 0) {
numBytes = strlen(script);
}
/* Each iteration compiles one command from the script. */
if (numBytes > 0) {
if (numBytes >= INT_MAX) {
/*
* Note this gets -errorline as 1. Not worth figuring out which line
* crosses the limit to get -errorline for this error case.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Script length %" TCL_SIZE_MODIFIER
"d exceeds max permitted length %d.",
numBytes, INT_MAX-1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "SCRIPTLENGTH", (char *)NULL);
TclCompileSyntaxError(interp, envPtr);
return;
}
/*
* Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so
* many nested compilations (body enclosed in body) can cause abnormal
* program termination with a stack overflow exception, bug [fec0c17d39].
*/
Tcl_Parse *parsePtr = (Tcl_Parse *)Tcl_Alloc(sizeof(Tcl_Parse));
do {
const char *next;
if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) {
/*
* Compile bytecodes to report the parsePtr error at runtime.
*/
Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
parsePtr->term + 1 - parsePtr->commandStart);
TclCompileSyntaxError(interp, envPtr);
Tcl_Free(parsePtr);
return;
}
#ifdef TCL_COMPILE_DEBUG
/*
* If tracing, print a line for each top level command compiled.
* TODO: Suppress when numWords == 0 ?
*/
if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
int commandLength = parsePtr->term - parsePtr->commandStart;
fprintf(stdout, " Compiling: ");
TclPrintSource(stdout, parsePtr->commandStart,
TclMin(commandLength, 55));
fprintf(stdout, "\n");
}
#endif
/*
* TIP #280: Count newlines before the command start.
* (See test info-30.33).
*/
TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
parsePtr->commandStart - envPtr->source);
/*
* Advance parser to the next command in the script.
*/
next = parsePtr->commandStart + parsePtr->commandSize;
numBytes -= next - p;
p = next;
if (parsePtr->numWords == 0) {
/*
* The "command" parsed has no words. In this case we can skip
* the rest of the loop body. With no words, clearly
* CompileCommandTokens() has nothing to do. Since the parser
* aggressively sucks up leading comment and white space,
* including newlines, parsePtr->commandStart must be pointing at
* either the end of script, or a command-terminating semi-colon.
* In either case, the TclAdvance*() calls have nothing to do.
* Finally, when no words are parsed, no tokens have been
* allocated at parsePtr->tokenPtr so there's also nothing for
* Tcl_FreeParse() to do.
*
* The advantage of this shortcut is that CompileCommandTokens()
* can be written with an assumption that (int)parsePtr->numWords > 0, with
* the implication the CCT() always generates bytecode.
*/
continue;
}
/*
* Avoid stack exhaustion by too many nested calls of TclCompileScript
* (considering interp recursionlimit).
*/
iPtr->numLevels++;
lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr);
iPtr->numLevels--;
/*
* TIP #280: Track lines in the just compiled command.
*/
TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
p - envPtr->source);
Tcl_FreeParse(parsePtr);
} while (numBytes > 0);
Tcl_Free(parsePtr);
}
if (lastCmdIdx == -1) {
/*
* Compiling the script yielded no bytecode. The script must be all
* whitespace, comments, and empty commands. Such scripts are defined
* to successfully produce the empty string result, so we emit the
|
| ︙ | ︙ | |||
2370 2371 2372 2373 2374 2375 2376 |
* namespace qualifiers it is not a local variable (localVarName=-1); if
* it looks like an array element and the token has a single component, it
* should not be created here [Bug 569438] (localVarName=0); otherwise,
* the local variable can safely be created (localVarName=1).
*/
for (i = 0, p = name; i < nameBytes; i++, p++) {
| | | | | 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 |
* namespace qualifiers it is not a local variable (localVarName=-1); if
* it looks like an array element and the token has a single component, it
* should not be created here [Bug 569438] (localVarName=0); otherwise,
* the local variable can safely be created (localVarName=1).
*/
for (i = 0, p = name; i < nameBytes; i++, p++) {
if ((p[0] == ':') && (i < nameBytes-1) && (p[1] == ':')) {
localVarName = -1;
break;
} else if ((p[0] == '(')
&& (tokenPtr->numComponents == 1)
&& (name[nameBytes - 1] == ')')) {
localVarName = 0;
break;
}
}
/*
* Either push the variable's name, or find its index in the array
|
| ︙ | ︙ | |||
2499 2500 2501 2502 2503 2504 2505 | * script). We may have to extend the table of locations. * * The continuation line information is relevant even if the word * being processed is not a literal, as it can affect nested * commands. See the branch below for TCL_TOKEN_COMMAND, where the * adjustment being tracked here is taken into account. The good * thing is a table of everything is not needed, just the number of | | | | | 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 |
* script). We may have to extend the table of locations.
*
* The continuation line information is relevant even if the word
* being processed is not a literal, as it can affect nested
* commands. See the branch below for TCL_TOKEN_COMMAND, where the
* adjustment being tracked here is taken into account. The good
* thing is a table of everything is not needed, just the number of
* lines to add as correction.
*/
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (Tcl_Size *)Tcl_Realloc(clPosition,
maxNumCL * sizeof(Tcl_Size));
}
clPosition[numCL] = clPos;
numCL ++;
}
adjust++;
}
break;
|
| ︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 |
*----------------------------------------------------------------------
*/
void
TclCompileExprWords(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Points to first in an array of word tokens
| | < | 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 |
*----------------------------------------------------------------------
*/
void
TclCompileExprWords(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Points to first in an array of word tokens
* for the expression to compile inline. */
size_t numWords1, /* Number of word tokens starting at tokenPtr.
* Must be at least 1. Each word token
* contains one or more subtokens. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_Token *wordPtr;
int i, concatItems;
|
| ︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 | * Prevent circular reference where the bytecode internalrep of * a value contains a literal which is that same value. * If this is allowed to happen, refcount decrements may not * reach zero, and memory may leak. Bugs 467523, 3357771 * * NOTE: [Bugs 3392070, 3389764] We make a copy based completely * on the string value, and do not call Tcl_DuplicateObj() so we | | | | 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 | * Prevent circular reference where the bytecode internalrep of * a value contains a literal which is that same value. * If this is allowed to happen, refcount decrements may not * reach zero, and memory may leak. Bugs 467523, 3357771 * * NOTE: [Bugs 3392070, 3389764] We make a copy based completely * on the string value, and do not call Tcl_DuplicateObj() so we * can be sure we do not have any lingering cycles hiding in * the internalrep. */ Tcl_Size numBytes; const char *bytes = TclGetStringFromObj(objPtr, &numBytes); Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); Tcl_IncrRefCount(copyPtr); TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); envPtr->literalArrayPtr[i].objPtr = copyPtr; } |
| ︙ | ︙ | |||
3068 3069 3070 3071 3072 3073 3074 |
if (!cachePtr || !name) {
return TCL_INDEX_NONE;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
| | | 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 |
if (!cachePtr || !name) {
return TCL_INDEX_NONE;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
localName = TclGetStringFromObj(*varNamePtr, &len);
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
}
}
return TCL_INDEX_NONE;
}
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | * what level of tracing is desired: * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | * what level of tracing is desired: * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ MODULE_SCOPE int tclTraceCompile; /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: * 0: no execution tracing * 1: trace invocations of Tcl procs only * 2: trace invocations of all (not compiled away) commands * 3: display each instruction executed * This variable is linked to the Tcl variable "tcl_traceExec". */ MODULE_SCOPE int tclTraceExec; #endif /* * The type of lambda expressions. Note that every lambda will *always* have a * string representation. */ |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch
* command. Errors in the range cause a jump
* to a catch PC offset. */
} ExceptionRangeType;
typedef struct {
ExceptionRangeType type; /* The kind of ExceptionRange. */
| | | | | | | | | | | | | | > | > | | | | | | | | | | | | | | 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 |
CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch
* command. Errors in the range cause a jump
* to a catch PC offset. */
} ExceptionRangeType;
typedef struct {
ExceptionRangeType type; /* The kind of ExceptionRange. */
Tcl_Size nestingLevel; /* Static depth of the exception range. Used
* to find the most deeply-nested range
* surrounding a PC at runtime. */
Tcl_Size codeOffset; /* Offset of the first instruction byte of the
* code range. */
Tcl_Size numCodeBytes; /* Number of bytes in the code range. */
Tcl_Size breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
* offset for a break command in the range. */
Tcl_Size continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE,
* the target PC offset for a continue command
* in the code range. Otherwise, ignore this
* range when processing a continue
* command. */
Tcl_Size catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
* offset for any "exception" in range. */
} ExceptionRange;
/*
* Auxiliary data used when issuing (currently just loop) exception ranges,
* but which is not required during execution.
*/
typedef struct ExceptionAux {
int supportsContinue; /* Whether this exception range will have a
* continueOffset created for it; if it is a
* loop exception range that *doesn't* have
* one (see [for] next-clause) then we must
* not pick up the range when scanning for a
* target to continue to. */
Tcl_Size stackDepth; /* The stack depth at the point where the
* exception range was created. This is used
* to calculate the number of POPs required to
* restore the stack to its prior state. */
Tcl_Size expandTarget; /* The number of expansions expected on the
* auxData stack at the time the loop starts;
* we can't currently discard them except by
* doing INST_INVOKE_EXPANDED; this is a known
* problem. */
Tcl_Size expandTargetDepth; /* The stack depth expected at the outermost
* expansion within the loop. Not meaningful
* if there are no open expansions between the
* looping level and the point of jump
* issue. */
Tcl_Size numBreakTargets; /* The number of [break]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
TCL_HASH_TYPE *breakTargets;/* The offsets of the INST_JUMP4 instructions
* issued by the [break]s that we must
* update. Note that resizing a jump (via
* TclFixupForwardJump) can cause the contents
* of this array to be updated. When
* numBreakTargets==0, this is NULL. */
Tcl_Size allocBreakTargets; /* The size of the breakTargets array. */
Tcl_Size numContinueTargets;/* The number of [continue]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
TCL_HASH_TYPE *continueTargets;
/* The offsets of the INST_JUMP4 instructions
* issued by the [continue]s that we must
* update. Note that resizing a jump (via
* TclFixupForwardJump) can cause the contents
* of this array to be updated. When
* numContinueTargets==0, this is NULL. */
Tcl_Size allocContinueTargets;
/* The size of the continueTargets array. */
} ExceptionAux;
/*
* Structure used to map between instruction pc and source locations. It
* defines for each compiled Tcl command its code's starting offset and its
* source's starting offset and length. Note that the code offset increases
* monotonically: that is, the table is sorted in code offset order. The
* source offset is not monotonic.
*/
typedef struct {
Tcl_Size codeOffset; /* Offset of first byte of command code. */
Tcl_Size numCodeBytes; /* Number of bytes for command's code. */
Tcl_Size srcOffset; /* Offset of first char of the command. */
Tcl_Size numSrcBytes; /* Number of command source chars. */
} CmdLocation;
/*
* TIP #280
* Structure to record additional location information for byte code. This
* information is internal and not saved. i.e. tbcload'ed code will not have
* this information. It records the lines for all words of all commands found
* in the byte code. The association with a ByteCode structure BC is done
* through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
* Also recorded is information coming from the context, i.e. type of the
* frame and associated information, like the path of a sourced file.
*/
typedef struct {
Tcl_Size srcOffset; /* Command location to find the entry. */
Tcl_Size nline; /* Number of words in the command */
Tcl_Size *line; /* Line information for all words in the
* command. */
Tcl_Size **next; /* Transient information used by the compiler
* for tracking of hidden continuation
* lines. */
} ECL;
typedef struct {
int type; /* Context type. */
Tcl_Size start; /* Starting line for compiled script. Needed
* for the extended recompile check in
* tclCompileObj. */
Tcl_Obj *path; /* Path of the sourced file the command is
* in. */
ECL *loc; /* Command word locations (lines). */
Tcl_Size nloc; /* Number of allocated entries in 'loc'. */
Tcl_Size nuloc; /* Number of used entries in 'loc'. */
} ExtCmdLoc;
/*
* CompileProcs need the ability to record information during compilation that
* can be used by bytecode instructions during execution. The AuxData
* structure provides this "auxiliary data" mechanism. An arbitrary number of
* these structures can be stored in the ByteCode record (during compilation
* they are stored in a CompileEnv structure). Each AuxData record holds one
* word of client-specified data (often a pointer) and is given an index that
* instructions can later use to look up the structure and its data.
*
* The following definitions declare the types of procedures that are called
* to duplicate or free this auxiliary data when the containing ByteCode
* objects are duplicated and freed. Pointers to these procedures are kept in
* the AuxData structure.
*/
typedef void * (AuxDataDupProc) (void *clientData);
typedef void (AuxDataFreeProc) (void *clientData);
typedef void (AuxDataPrintProc) (void *clientData,
Tcl_Obj *appendObj, struct ByteCode *codePtr,
TCL_HASH_TYPE pcOffset);
/*
* We define a separate AuxDataType struct to hold type-related information
* for the AuxData structure. This separation makes it possible for clients
* outside of the TCL core to manipulate (in a limited fashion!) AuxData; for
* example, it makes it possible to pickle and unpickle AuxData structs.
*/
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
* during compilation by CompileProcs and used by instructions during
* execution.
*/
typedef struct AuxData {
const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
| | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
* during compilation by CompileProcs and used by instructions during
* execution.
*/
typedef struct AuxData {
const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
void *clientData; /* The compilation data itself. */
} AuxData;
/*
* Structure defining the compilation environment. After compilation, fields
* describing bytecode instructions are copied out into the more compact
* ByteCode structure defined below.
*/
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
* compiled. Commands and their compile procs
* are specific to an interpreter so the code
* emitted will depend on the interpreter. */
const char *source; /* The source string being compiled by
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
| | | | > | | | > | | | | | | 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 |
* compiled. Commands and their compile procs
* are specific to an interpreter so the code
* emitted will depend on the interpreter. */
const char *source; /* The source string being compiled by
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
Tcl_Size numSrcBytes; /* Number of bytes in source. */
Proc *procPtr; /* If a procedure is being compiled, a pointer
* to its Proc structure; otherwise NULL. Used
* to compile local variables. Set from
* information provided by ObjInterpProc in
* tclProc.c. */
Tcl_Size numCommands; /* Number of commands compiled. */
Tcl_Size exceptDepth; /* Current exception range nesting level;
* TCL_INDEX_NONE if not in any range
* currently. */
Tcl_Size maxExceptDepth; /* Max nesting level of exception ranges;
* TCL_INDEX_NONE if no ranges have been
* compiled. */
Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to
* execute the code. Set by compilation
* procedures before returning. */
Tcl_Size currStackDepth; /* Current stack depth. */
LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl
* objects referenced by this compiled code.
* Indexed by the string representations of
* the literals. Used to avoid creating
* duplicate objects. */
unsigned char *codeStart; /* Points to the first byte of the code. */
unsigned char *codeNext; /* Points to next code array byte to use. */
unsigned char *codeEnd; /* Points just after the last allocated code
* array byte. */
int mallocedCodeArray; /* Set 1 if code array was expanded and
* codeStart points into the heap.*/
#if TCL_MAJOR_VERSION > 8
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
#endif
LiteralEntry *literalArrayPtr;
/* Points to start of LiteralEntry array. */
Tcl_Size literalArrayNext; /* Index of next free object array entry. */
Tcl_Size literalArrayEnd; /* Index just after last obj array entry. */
int mallocedLiteralArray; /* 1 if object array was expanded and objArray
* points into the heap, else 0. */
ExceptionRange *exceptArrayPtr;
/* Points to start of the ExceptionRange
* array. */
Tcl_Size exceptArrayNext; /* Next free ExceptionRange array index.
* exceptArrayNext is the number of ranges and
* (exceptArrayNext-1) is the index of the
* current range's array entry. */
Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array
* entry. */
#if TCL_MAJOR_VERSION < 9
int mallocedExceptArray;
#endif
ExceptionAux *exceptAuxArrayPtr;
/* Array of information used to restore the
* state when processing BREAK/CONTINUE
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 |
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
/* Initial storage for aux data array. */
/* TIP #280 */
ExtCmdLoc *extCmdMapPtr; /* Extended command location information for
* 'info frame'. */
| | | | | 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 |
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
/* Initial storage for aux data array. */
/* TIP #280 */
ExtCmdLoc *extCmdMapPtr; /* Extended command location information for
* 'info frame'. */
Tcl_Size line; /* First line of the script, based on the
* invoking context, then the line of the
* command currently compiled. */
int atCmdStart; /* Flag to say whether an INST_START_CMD
* should be issued; they should never be
* issued repeatedly, as that is significantly
* inefficient. If set to 2, that instruction
* should not be issued at all (by the generic
* part of the command compiler). */
Tcl_Size expandCount; /* Number of INST_EXPAND_START instructions
* encountered that have not yet been paired
* with a corresponding
* INST_INVOKE_EXPANDED. */
Tcl_Size *clNext; /* If not NULL, it refers to the next slot in
* clLoc to check for an invisible
* continuation line. */
} CompileEnv;
/*
* The structure defining the bytecode instructions resulting from compiling a
* Tcl script. Note that this structure is variable length: a single heap
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
| | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 |
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
Tcl_Size compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
Namespace *nsPtr; /* Namespace context in which this code was
* compiled. If the code is executed if a
* different namespace, it must be
* recompiled. */
|
| ︙ | ︙ | |||
455 456 457 458 459 460 461 |
* Proc structure; otherwise NULL. This
* pointer is also not owned by the ByteCode
* and must not be freed by it. */
size_t structureSize; /* Number of bytes in the ByteCode structure
* itself. Does not include heap space for
* literal Tcl objects or storage referenced
* by AuxData entries. */
| | | | | | | | | | 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 |
* Proc structure; otherwise NULL. This
* pointer is also not owned by the ByteCode
* and must not be freed by it. */
size_t structureSize; /* Number of bytes in the ByteCode structure
* itself. Does not include heap space for
* literal Tcl objects or storage referenced
* by AuxData entries. */
Tcl_Size numCommands; /* Number of commands compiled. */
Tcl_Size numSrcBytes; /* Number of source bytes compiled. */
Tcl_Size numCodeBytes; /* Number of code bytes. */
Tcl_Size numLitObjects; /* Number of objects in literal array. */
Tcl_Size numExceptRanges; /* Number of ExceptionRange array elems. */
Tcl_Size numAuxDataItems; /* Number of AuxData items. */
Tcl_Size numCmdLocBytes; /* Number of bytes needed for encoded command
* location information. */
Tcl_Size maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
* TCL_INDEX_NONE if no ranges were compiled. */
Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to
* execute the code. */
unsigned char *codeStart; /* Points to the first byte of the code. This
* is just after the final ByteCode member
* cmdMapPtr. */
Tcl_Obj **objArrayPtr; /* Points to the start of the literal object
* array. This is just after the last code
* byte. */
ExceptionRange *exceptArrayPtr;
/* Points to the start of the ExceptionRange
* array. This is just after the last object
* in the object array. */
AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data
* array. This is just after the last entry in
* the ExceptionRange array. */
unsigned char *codeDeltaStart;
/* Points to the first of a sequence of bytes
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
* variables. */
#ifdef TCL_COMPILE_STATS
Tcl_Time createTime; /* Absolute time when the ByteCode was
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
| | < < | | | | | 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 |
* variables. */
#ifdef TCL_COMPILE_STATS
Tcl_Time createTime; /* Absolute time when the ByteCode was
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
#define ByteCodeSetInternalRep(objPtr, typePtr, codePtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (codePtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), (typePtr), &ir); \
} while (0)
#define ByteCodeGetInternalRep(objPtr, typePtr, codePtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), (typePtr)); \
(codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to the
* entries in the table of instruction descriptions, tclInstructionTable, in
* tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
* INST_BITOR) must match the entries in the array operatorStrings in
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
INST_LAPPEND_LIST_ARRAY_STK,
INST_LAPPEND_LIST_STK,
INST_CLOCK_READ,
INST_DICT_GET_DEF,
| | | | | | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
INST_LAPPEND_LIST_ARRAY_STK,
INST_LAPPEND_LIST_STK,
INST_CLOCK_READ,
INST_DICT_GET_DEF,
/* 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,
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
* to 5 bytes. */
} JumpFixup;
#define JUMPFIXUP_INIT_ENTRIES 10
typedef struct JumpFixupArray {
JumpFixup *fixup; /* Points to start of jump fixup array. */
| | | | > | | | > | 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 |
* to 5 bytes. */
} JumpFixup;
#define JUMPFIXUP_INIT_ENTRIES 10
typedef struct JumpFixupArray {
JumpFixup *fixup; /* Points to start of jump fixup array. */
Tcl_Size next; /* Index of next free array entry. */
Tcl_Size end; /* Index of last usable entry in array. */
int mallocedArray; /* 1 if array was expanded and fixups points
* into the heap, else 0. */
JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES];
/* Initial storage for jump fixup array. */
} JumpFixupArray;
/*
* The structure describing one variable list of a foreach command. Note that
* only foreach commands inside procedure bodies are compiled inline so a
* ForeachVarList structure always describes local variables. Furthermore,
* only scalar variables are supported for inline-compiled foreach loops.
*/
typedef struct ForeachVarList {
Tcl_Size numVars; /* The number of variables in the list. */
Tcl_Size varIndexes[TCLFLEXARRAY];
/* An array of the indexes ("slot numbers")
* for each variable in the procedure's array
* of local variables. Only scalar variables
* are supported. The actual size of this
* field will be large enough to numVars
* indexes. THIS MUST BE THE LAST FIELD IN THE
* STRUCTURE! */
} ForeachVarList;
/*
* Structure used to hold information about a foreach command that is needed
* during program execution. These structures are stored in CompileEnv and
* ByteCode structures as auxiliary data.
*/
typedef struct ForeachInfo {
Tcl_Size numLists; /* The number of both the variable and value
* lists of the foreach command. */
Tcl_Size firstValueTemp; /* Index of the first temp var in a proc frame
* used to point to a value list. */
Tcl_Size loopCtTemp; /* Index of temp var in a proc frame holding
* the loop's iteration count. Used to
* determine next value list element to assign
* each loop var. */
ForeachVarList *varLists[TCLFLEXARRAY];
/* An array of pointers to ForeachVarList
* structures describing each var list. The
* actual size of this field will be large
* enough to numVars indexes. THIS MUST BE THE
* LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;
/*
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 |
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
* and ByteCode structures as auxiliary data.
*/
typedef struct {
Tcl_Size length; /* Size of array */
| | > | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
* and ByteCode structures as auxiliary data.
*/
typedef struct {
Tcl_Size length; /* Size of array */
Tcl_Size varIndices[TCLFLEXARRAY];
/* Array of variable indices to manage when
* processing the start and end of a [dict
* update]. There is really more than one
* entry, and the structure is allocated to
* take account of this. MUST BE LAST FIELD IN
* STRUCTURE. */
} DictUpdateInfo;
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | #endif MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG | | | > | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 | #endif MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclDebugPrintByteCodeObj(Tcl_Obj *objPtr); #else #define TclDebugPrintByteCodeObj(objPtr) (void)(objPtr) #endif MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, const unsigned char *pc); MODULE_SCOPE void TclPrintObject(FILE *outFile, Tcl_Obj *objPtr, Tcl_Size maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, const char *string, Tcl_Size maxChars); |
| ︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 | #endif MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length, const unsigned char *pc, Tcl_Obj **tosPtr); | | | < | 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 | #endif MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); #endif /* TCL_MAJOR_VERSION > 8 */ /* *---------------------------------------------------------------- * Macros and flag values used by Tcl bytecode compilation and execution * modules inside the Tcl core but not used outside. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1226 1227 1228 1229 1230 1231 1232 |
(envPtr)->auxDataArrayPtr[(index)].clientData
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
#define LITERAL_UNSHARED 0x04
/*
| | | | | > | > | | < < | | | < < > > | < | > | | > > > > > | < | > > | | > | < < > > | | | > | > > | | < < | | | | < > | < < > > | | | | | | | | | | 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 |
(envPtr)->auxDataArrayPtr[(index)].clientData
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
#define LITERAL_UNSHARED 0x04
/*
* Adjust the stack requirements. Manually used in cases where the stack
* effect cannot be computed from the opcode and its operands, but is still
* known at compile time.
*/
static inline void
TclAdjustStackDepth(
int delta,
CompileEnv *envPtr)
{
if (delta < 0) {
if ((int) envPtr->maxStackDepth < (int) envPtr->currStackDepth) {
envPtr->maxStackDepth = envPtr->currStackDepth;
}
}
envPtr->currStackDepth += delta;
}
#define TclGetStackDepth(envPtr) \
((envPtr)->currStackDepth)
#define TclSetStackDepth(depth, envPtr) \
(envPtr)->currStackDepth = (depth)
/*
* Verify that the current stack depth is what we think it should be. When
* this is wrong, code generation is broken!
*/
static inline void
TclCheckStackDepth(
size_t depth,
CompileEnv *envPtr)
{
if (depth != (size_t) envPtr->currStackDepth) {
Tcl_Panic("bad stack depth computations: "
"is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u",
(size_t) envPtr->currStackDepth, depth);
}
}
/*
* Update the stack requirements based on the instruction definition. It is
* called by the macros TclEmitOpCode, TclEmitInst1 and TclEmitInst4.
* Remark that the very last instruction of a bytecode always reduces the
* stack level: INST_DONE or INST_POP, so that the maxStackdepth is always
* updated.
*/
static inline void
TclUpdateStackReqs(
unsigned char op,
int i,
CompileEnv *envPtr)
{
int delta = tclInstructionTable[op].stackEffect;
if (delta) {
if (delta == INT_MIN) {
delta = 1 - i;
}
TclAdjustStackDepth(delta, envPtr);
}
}
/*
* Macros used to update the flag that indicates if we are at the start of a
* command, based on whether the opcode is INST_START_COMMAND.
*
* void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr);
*/
#define TclUpdateAtCmdStart(op, envPtr) \
if ((envPtr)->atCmdStart < 2) { \
(envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \
}
/*
* Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C
* "prototype" for this macro is:
*
* void TclEmitOpcode(unsigned char op, CompileEnv *envPtr);
*/
#define TclEmitOpcode(op, envPtr) \
do { \
if ((envPtr)->codeNext == (envPtr)->codeEnd) { \
TclExpandCodeArray(envPtr); \
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, 0, envPtr); \
} while (0)
/*
* Macros to emit an integer operand. The ANSI C "prototype" for these macros
* are:
*
* void TclEmitInt1(int i, CompileEnv *envPtr);
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \
TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, i, envPtr); \
} while (0)
#define TclEmitInstInt4(op, i, envPtr) \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 |
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \
TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, i, envPtr); \
} while (0)
#define TclEmitInstInt4(op, i, envPtr) \
do { \
if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \
TclExpandCodeArray(envPtr); \
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 24); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 16); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 8); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) ); \
TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, i, envPtr); \
} while (0)
/*
* Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
* object's one or four byte array index into the CompileEnv's code array.
* These support, respectively, a maximum of 256 (2**8) and 2**32 objects in a
* CompileEnv. The ANSI C "prototype" for this macro is:
*
* void TclEmitPush(int objIndex, CompileEnv *envPtr);
*/
#define TclEmitPush(objIndex, envPtr) \
do { \
int _objIndexCopy = (objIndex); \
if (_objIndexCopy <= 255) { \
TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \
} else { \
TclEmitInstInt4(INST_PUSH4, _objIndexCopy, (envPtr)); \
} \
} while (0)
/*
* Macros to update a (signed or unsigned) integer starting at a pointer. The
* two variants depend on the number of bytes. The ANSI C "prototypes" for
* these macros are:
*
* void TclStoreInt1AtPtr(int i, unsigned char *p);
* void TclStoreInt4AtPtr(int i, unsigned char *p);
*/
#define TclStoreInt1AtPtr(i, p) \
*(p) = (unsigned char) ((unsigned int) (i))
#define TclStoreInt4AtPtr(i, p) \
do { \
*(p) = (unsigned char) ((unsigned int) (i) >> 24); \
*(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
*(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \
*(p+3) = (unsigned char) ((unsigned int) (i) ); \
} while (0)
/*
* Macros to update instructions at a particular pc with a new op code and a
* (signed or unsigned) int operand. The ANSI C "prototypes" for these macros
* are:
*
* void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc);
* void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc);
*/
#define TclUpdateInstInt1AtPc(op, i, pc) \
do { \
*(pc) = (unsigned char) (op); \
TclStoreInt1AtPtr((i), ((pc)+1)); \
} while (0)
#define TclUpdateInstInt4AtPc(op, i, pc) \
do { \
*(pc) = (unsigned char) (op); \
TclStoreInt4AtPtr((i), ((pc)+1)); \
} while (0)
/*
* Macro to fix up a forward jump to point to the current code-generation
* position in the bytecode being created (the most common case). The ANSI C
* "prototypes" for this macro is:
*
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
#else
# define TclGetInt1AtPtr(p) \
((int) ((*((char *) p)) | ((*(p) & 0200) ? (-256) : 0)))
#endif
#define TclGetInt4AtPtr(p) \
| | | | | | | | | 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 |
# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
#else
# define TclGetInt1AtPtr(p) \
((int) ((*((char *) p)) | ((*(p) & 0200) ? (-256) : 0)))
#endif
#define TclGetInt4AtPtr(p) \
((int) ((TclGetUInt1AtPtr(p) << 24) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3))))
#define TclGetUInt1AtPtr(p) \
((unsigned int) *(p))
#define TclGetUInt4AtPtr(p) \
((unsigned int) ((*(p) << 24) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3))))
/*
* Macros used to compute the minimum and maximum of two values. The ANSI C
* "prototypes" for these macros are:
*
* size_t TclMin(size_t i, size_t j);
* size_t TclMax(size_t i, size_t j);
*/
#define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1 )? (i) : (j))
#define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1 )? (i) : (j))
/*
* Convenience macros for use when compiling bodies of commands. The ANSI C
* "prototype" for these macros are:
*
* static void BODY(Tcl_Token *tokenPtr, int word);
*/
#define BODY(tokenPtr, word) \
SetLineInformation((word)); \
TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \
envPtr)
/*
* Convenience macro for use when compiling tokens to be pushed. The ANSI C
* "prototype" for this macro is:
|
| ︙ | ︙ | |||
1811 1812 1813 1814 1815 1816 1817 | 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() \ | | | | | | | | | 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 |
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]; \
snprintf(n, sizeof(n), "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \
(size_t) getpid()); \
tclDTraceDebugLog = fopen(n, "a"); \
}
#define TclDTraceDbgMsg(p, m, ...) \
do { \
if (tclDTraceDebugEnabled) { \
int _l, _t = 0; \
if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \
|
| ︙ | ︙ | |||
1845 1846 1847 1848 1849 1850 1851 | #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) \ | | | | | | 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 |
#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) \
|
| ︙ | ︙ |
Changes to generic/tclConfig.c.
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
/*
* Extend the package configuration...
* We cannot assume that the encodings are initialized, therefore
* store the value as-is in a byte array. See Bug [9b2e636361].
*/
for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
| | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
/*
* Extend the package configuration...
* We cannot assume that the encodings are initialized, therefore
* store the value as-is in a byte array. See Bug [9b2e636361].
*/
for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
TclDictPut(interp, pkgDict, cfg->key,
Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
}
/*
* Write the changes back into the overall database.
*/
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
/*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
| | | | 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 |
/*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
TclGetString(pkgName), (char *)NULL);
return TCL_ERROR;
}
switch (index) {
case CFG_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "key");
return TCL_ERROR;
}
if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
if (cdPtr->encoding) {
venc = Tcl_GetEncoding(interp, cdPtr->encoding);
if (!venc) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
Tcl_DictObjSize(interp, pkgDict, &m);
listPtr = Tcl_NewListObj(m, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
| | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
Tcl_DictObjSize(interp, pkgDict, &m);
listPtr = Tcl_NewListObj(m, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
return TCL_ERROR;
}
if (m) {
Tcl_DictSearch s;
Tcl_Obj *key;
int done;
|
| ︙ | ︙ |
Changes to generic/tclDTrace.d.
| ︙ | ︙ | |||
205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
void *ptr1;
void *ptr2;
} twoPtrValue;
struct {
void *ptr;
unsigned long value;
} ptrAndLongRep;
} internalRep;
};
enum return_codes {
TCL_OK = 0,
TCL_ERROR,
TCL_RETURN,
| > > > > | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
void *ptr1;
void *ptr2;
} twoPtrValue;
struct {
void *ptr;
unsigned long value;
} ptrAndLongRep;
struct {
void *ptr;
Tcl_Size size;
} ptrAndSize;
} internalRep;
};
enum return_codes {
TCL_OK = 0,
TCL_ERROR,
TCL_RETURN,
|
| ︙ | ︙ |
Changes to generic/tclDate.c.
|
| | | > | > > > > | | | | | | < | | > | | > > | < < < | | < < > < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > > > > > > > | | | > > > > > > > > | > | > > > | < < < < < < < < | > > > > | | | | | | | | | < | | > > | | | > > | | > > < < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | < < > > > | | > > > > | < > > > > | > > > | | > > | | > > > > > | > > > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > | < | < | | < < < < < < | < < < | | | | < > > | | | > > > > > | > > > > > > > > > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 |
/* A Bison parser, made by GNU Bison 3.8.2. */
/* Bison implementation for Yacc-like parsers in C
Copyright (C) 1984, 1989-1990, 2000-2015, 2018-2021 Free Software Foundation,
Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>. */
/* As a special exception, you may create a larger work that contains
part or all of the Bison parser skeleton and distribute that work
under terms of your choice, so long as that work isn't itself a
parser generator using the skeleton or a modified version thereof
as a parser skeleton. Alternatively, if you modify or redistribute
the parser skeleton itself, you may (at your option) remove this
special exception, which will cause the skeleton and the resulting
Bison output files to be licensed under the GNU General Public
License without this special exception.
This special exception was added by the Free Software Foundation in
version 2.2 of Bison. */
/* C LALR(1) parser skeleton written by Richard Stallman, by
simplifying the original so-called "semantic" parser. */
/* DO NOT RELY ON FEATURES THAT ARE NOT DOCUMENTED in the manual,
especially those whose name start with YY_ or yy_. They are
private implementation details that can be changed or removed. */
/* All symbols defined below should begin with yy or YY, to avoid
infringing on user name space. This should be done even for local
variables, as they might otherwise be expanded by user macros.
There are some unavoidable exceptions within include files to
define necessary library symbols; they are noted "INFRINGES ON
USER NAME SPACE" below. */
/* Identify Bison output, and Bison version. */
#define YYBISON 30802
/* Bison version string. */
#define YYBISON_VERSION "3.8.2"
/* Skeleton name. */
#define YYSKELETON_NAME "yacc.c"
/* Pure parsers. */
#define YYPURE 1
/* Push parsers. */
#define YYPUSH 0
/* Pull parsers. */
#define YYPULL 1
/* Substitute the variable and function names. */
#define yyparse TclDateparse
#define yylex TclDatelex
#define yyerror TclDateerror
#define yydebug TclDatedebug
#define yynerrs TclDatenerrs
/* First part of user prologue. */
/*
* tclDate.c --
*
* This file is generated from a yacc grammar defined in the file
* tclGetDate.y. It should not be edited directly.
*
* Copyright © 1992-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright © 1995-1997 Sun Microsystems, Inc.
* Copyright © 2015 Sergey G. Brester aka sebres.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
*/
#include "tclInt.h"
/*
* Bison generates several labels that happen to be unused. Several compilers
* don't like that, and complain. Simply disable the warning to silence them.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#elif defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic ignored "-Wunused-but-set-variable"
#endif
#if 0
#define YYDEBUG 1
#endif
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
#include "tclDate.h"
#define YYMALLOC Tcl_Alloc
#define YYFREE(x) (Tcl_Free((void*) (x)))
#define EPOCH 1970
#define START_OF_TIME 1902
#define END_OF_TIME 2037
/*
* The offset of tm_year of struct tm returned by localtime, gmtime, etc.
* Posix requires 1900.
*/
#define TM_YEAR_BASE 1900
#define HOUR(x) ((60 * (int)(x)))
#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0))
#define yyIncrFlags(f) \
do { \
info->errFlags |= (info->flags & (f)); \
if (info->errFlags) { YYABORT; } \
info->flags |= (f); \
} while (0);
/*
* An entry in the lexical lookup table.
*/
typedef struct {
const char *name;
int type;
int value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
# ifndef YY_CAST
# ifdef __cplusplus
# define YY_CAST(Type, Val) static_cast<Type> (Val)
# define YY_REINTERPRET_CAST(Type, Val) reinterpret_cast<Type> (Val)
# else
# define YY_CAST(Type, Val) ((Type) (Val))
# define YY_REINTERPRET_CAST(Type, Val) ((Type) (Val))
# endif
# endif
# ifndef YY_NULLPTR
# if defined __cplusplus
# if 201103L <= __cplusplus
# define YY_NULLPTR nullptr
# else
# define YY_NULLPTR 0
# endif
# else
# define YY_NULLPTR ((void*)0)
# endif
# endif
/* Debug traces. */
#ifndef YYDEBUG
# define YYDEBUG 0
#endif
#if YYDEBUG
extern int TclDatedebug;
#endif
/* Token kinds. */
#ifndef YYTOKENTYPE
# define YYTOKENTYPE
enum yytokentype
{
YYEMPTY = -2,
YYEOF = 0, /* "end of file" */
YYerror = 256, /* error */
YYUNDEF = 257, /* "invalid token" */
tAGO = 258, /* tAGO */
tDAY = 259, /* tDAY */
tDAYZONE = 260, /* tDAYZONE */
tID = 261, /* tID */
tMERIDIAN = 262, /* tMERIDIAN */
tMONTH = 263, /* tMONTH */
tMONTH_UNIT = 264, /* tMONTH_UNIT */
tSTARDATE = 265, /* tSTARDATE */
tSEC_UNIT = 266, /* tSEC_UNIT */
tUNUMBER = 267, /* tUNUMBER */
tZONE = 268, /* tZONE */
tZONEwO4 = 269, /* tZONEwO4 */
tZONEwO2 = 270, /* tZONEwO2 */
tEPOCH = 271, /* tEPOCH */
tDST = 272, /* tDST */
tISOBAS8 = 273, /* tISOBAS8 */
tISOBAS6 = 274, /* tISOBAS6 */
tISOBASL = 275, /* tISOBASL */
tDAY_UNIT = 276, /* tDAY_UNIT */
tNEXT = 277, /* tNEXT */
SP = 278 /* SP */
};
typedef enum yytokentype yytoken_kind_t;
#endif
/* Value type. */
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
union YYSTYPE
{
Tcl_WideInt Number;
enum _MERIDIAN Meridian;
};
typedef union YYSTYPE YYSTYPE;
# define YYSTYPE_IS_TRIVIAL 1
# define YYSTYPE_IS_DECLARED 1
#endif
/* Location type. */
#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED
typedef struct YYLTYPE YYLTYPE;
struct YYLTYPE
{
int first_line;
int first_column;
int last_line;
int last_column;
};
# define YYLTYPE_IS_DECLARED 1
# define YYLTYPE_IS_TRIVIAL 1
#endif
int TclDateparse (DateInfo* info);
/* Symbol kind. */
enum yysymbol_kind_t
{
YYSYMBOL_YYEMPTY = -2,
YYSYMBOL_YYEOF = 0, /* "end of file" */
YYSYMBOL_YYerror = 1, /* error */
YYSYMBOL_YYUNDEF = 2, /* "invalid token" */
YYSYMBOL_tAGO = 3, /* tAGO */
YYSYMBOL_tDAY = 4, /* tDAY */
YYSYMBOL_tDAYZONE = 5, /* tDAYZONE */
YYSYMBOL_tID = 6, /* tID */
YYSYMBOL_tMERIDIAN = 7, /* tMERIDIAN */
YYSYMBOL_tMONTH = 8, /* tMONTH */
YYSYMBOL_tMONTH_UNIT = 9, /* tMONTH_UNIT */
YYSYMBOL_tSTARDATE = 10, /* tSTARDATE */
YYSYMBOL_tSEC_UNIT = 11, /* tSEC_UNIT */
YYSYMBOL_tUNUMBER = 12, /* tUNUMBER */
YYSYMBOL_tZONE = 13, /* tZONE */
YYSYMBOL_tZONEwO4 = 14, /* tZONEwO4 */
YYSYMBOL_tZONEwO2 = 15, /* tZONEwO2 */
YYSYMBOL_tEPOCH = 16, /* tEPOCH */
YYSYMBOL_tDST = 17, /* tDST */
YYSYMBOL_tISOBAS8 = 18, /* tISOBAS8 */
YYSYMBOL_tISOBAS6 = 19, /* tISOBAS6 */
YYSYMBOL_tISOBASL = 20, /* tISOBASL */
YYSYMBOL_tDAY_UNIT = 21, /* tDAY_UNIT */
YYSYMBOL_tNEXT = 22, /* tNEXT */
YYSYMBOL_SP = 23, /* SP */
YYSYMBOL_24_ = 24, /* ':' */
YYSYMBOL_25_ = 25, /* ',' */
YYSYMBOL_26_ = 26, /* '-' */
YYSYMBOL_27_ = 27, /* '/' */
YYSYMBOL_28_T_ = 28, /* 'T' */
YYSYMBOL_29_ = 29, /* '.' */
YYSYMBOL_30_ = 30, /* '+' */
YYSYMBOL_YYACCEPT = 31, /* $accept */
YYSYMBOL_spec = 32, /* spec */
YYSYMBOL_item = 33, /* item */
YYSYMBOL_iextime = 34, /* iextime */
YYSYMBOL_time = 35, /* time */
YYSYMBOL_zone = 36, /* zone */
YYSYMBOL_comma = 37, /* comma */
YYSYMBOL_day = 38, /* day */
YYSYMBOL_iexdate = 39, /* iexdate */
YYSYMBOL_date = 40, /* date */
YYSYMBOL_ordMonth = 41, /* ordMonth */
YYSYMBOL_isosep = 42, /* isosep */
YYSYMBOL_isodate = 43, /* isodate */
YYSYMBOL_isotime = 44, /* isotime */
YYSYMBOL_iso = 45, /* iso */
YYSYMBOL_trek = 46, /* trek */
YYSYMBOL_relspec = 47, /* relspec */
YYSYMBOL_relunits = 48, /* relunits */
YYSYMBOL_sign = 49, /* sign */
YYSYMBOL_unit = 50, /* unit */
YYSYMBOL_INTNUM = 51, /* INTNUM */
YYSYMBOL_numitem = 52, /* numitem */
YYSYMBOL_o_merid = 53 /* o_merid */
};
typedef enum yysymbol_kind_t yysymbol_kind_t;
/* Second part of user prologue. */
/*
* Prototypes of internal functions.
*/
static int LookupWord(YYSTYPE* yylvalPtr, char *buff);
static void TclDateerror(YYLTYPE* location,
DateInfo* info, const char *s);
static int TclDatelex(YYSTYPE* yylvalPtr, YYLTYPE* location,
DateInfo* info);
MODULE_SCOPE int yyparse(DateInfo*);
#ifdef short
# undef short
#endif
/* On compilers that do not define __PTRDIFF_MAX__ etc., make sure
<limits.h> and (if available) <stdint.h> are included
so that the code can choose integer types of a good width. */
#ifndef __PTRDIFF_MAX__
# include <limits.h> /* INFRINGES ON USER NAME SPACE */
# if defined __STDC_VERSION__ && 199901 <= __STDC_VERSION__
# include <stdint.h> /* INFRINGES ON USER NAME SPACE */
# define YY_STDINT_H
# endif
#endif
/* Narrow types that promote to a signed type and that can represent a
signed or unsigned integer of at least N bits. In tables they can
save space and decrease cache pressure. Promoting to a signed type
helps avoid bugs in integer arithmetic. */
#ifdef __INT_LEAST8_MAX__
typedef __INT_LEAST8_TYPE__ yytype_int8;
#elif defined YY_STDINT_H
typedef int_least8_t yytype_int8;
#else
typedef signed char yytype_int8;
#endif
#ifdef __INT_LEAST16_MAX__
typedef __INT_LEAST16_TYPE__ yytype_int16;
#elif defined YY_STDINT_H
typedef int_least16_t yytype_int16;
#else
typedef short yytype_int16;
#endif
/* Work around bug in HP-UX 11.23, which defines these macros
incorrectly for preprocessor constants. This workaround can likely
be removed in 2023, as HPE has promised support for HP-UX 11.23
(aka HP-UX 11i v2) only through the end of 2022; see Table 2 of
<https://h20195.www2.hpe.com/V2/getpdf.aspx/4AA4-7673ENW.pdf>. */
#ifdef __hpux
# undef UINT_LEAST8_MAX
# undef UINT_LEAST16_MAX
# define UINT_LEAST8_MAX 255
# define UINT_LEAST16_MAX 65535
#endif
#if defined __UINT_LEAST8_MAX__ && __UINT_LEAST8_MAX__ <= __INT_MAX__
typedef __UINT_LEAST8_TYPE__ yytype_uint8;
#elif (!defined __UINT_LEAST8_MAX__ && defined YY_STDINT_H \
&& UINT_LEAST8_MAX <= INT_MAX)
typedef uint_least8_t yytype_uint8;
#elif !defined __UINT_LEAST8_MAX__ && UCHAR_MAX <= INT_MAX
typedef unsigned char yytype_uint8;
#else
typedef short yytype_uint8;
#endif
#if defined __UINT_LEAST16_MAX__ && __UINT_LEAST16_MAX__ <= __INT_MAX__
typedef __UINT_LEAST16_TYPE__ yytype_uint16;
#elif (!defined __UINT_LEAST16_MAX__ && defined YY_STDINT_H \
&& UINT_LEAST16_MAX <= INT_MAX)
typedef uint_least16_t yytype_uint16;
#elif !defined __UINT_LEAST16_MAX__ && USHRT_MAX <= INT_MAX
typedef unsigned short yytype_uint16;
#else
typedef int yytype_uint16;
#endif
#ifndef YYPTRDIFF_T
# if defined __PTRDIFF_TYPE__ && defined __PTRDIFF_MAX__
# define YYPTRDIFF_T __PTRDIFF_TYPE__
# define YYPTRDIFF_MAXIMUM __PTRDIFF_MAX__
# elif defined PTRDIFF_MAX
# ifndef ptrdiff_t
# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
# endif
# define YYPTRDIFF_T ptrdiff_t
# define YYPTRDIFF_MAXIMUM PTRDIFF_MAX
# else
# define YYPTRDIFF_T long
# define YYPTRDIFF_MAXIMUM LONG_MAX
# endif
#endif
#ifndef YYSIZE_T
# ifdef __SIZE_TYPE__
# define YYSIZE_T __SIZE_TYPE__
# elif defined size_t
# define YYSIZE_T size_t
# elif defined __STDC_VERSION__ && 199901 <= __STDC_VERSION__
# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
# define YYSIZE_T size_t
# else
# define YYSIZE_T unsigned
# endif
#endif
#define YYSIZE_MAXIMUM \
YY_CAST (YYPTRDIFF_T, \
(YYPTRDIFF_MAXIMUM < YY_CAST (YYSIZE_T, -1) \
? YYPTRDIFF_MAXIMUM \
: YY_CAST (YYSIZE_T, -1)))
#define YYSIZEOF(X) YY_CAST (YYPTRDIFF_T, sizeof (X))
/* Stored state numbers (used for stacks). */
typedef yytype_int8 yy_state_t;
/* State numbers in computations. */
typedef int yy_state_fast_t;
#ifndef YY_
# if defined YYENABLE_NLS && YYENABLE_NLS
# if ENABLE_NLS
# include <libintl.h> /* INFRINGES ON USER NAME SPACE */
# define YY_(Msgid) dgettext ("bison-runtime", Msgid)
# endif
# endif
# ifndef YY_
# define YY_(Msgid) Msgid
# endif
#endif
#ifndef YY_ATTRIBUTE_PURE
# if defined __GNUC__ && 2 < __GNUC__ + (96 <= __GNUC_MINOR__)
# define YY_ATTRIBUTE_PURE __attribute__ ((__pure__))
# else
# define YY_ATTRIBUTE_PURE
# endif
#endif
#ifndef YY_ATTRIBUTE_UNUSED
# if defined __GNUC__ && 2 < __GNUC__ + (7 <= __GNUC_MINOR__)
# define YY_ATTRIBUTE_UNUSED __attribute__ ((__unused__))
# else
# define YY_ATTRIBUTE_UNUSED
# endif
#endif
/* Suppress unused-variable warnings by "using" E. */
#if ! defined lint || defined __GNUC__
# define YY_USE(E) ((void) (E))
#else
# define YY_USE(E) /* empty */
#endif
/* Suppress an incorrect diagnostic about yylval being uninitialized. */
#if defined __GNUC__ && ! defined __ICC && 406 <= __GNUC__ * 100 + __GNUC_MINOR__
# if __GNUC__ * 100 + __GNUC_MINOR__ < 407
# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \
_Pragma ("GCC diagnostic push") \
_Pragma ("GCC diagnostic ignored \"-Wuninitialized\"")
# else
# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \
_Pragma ("GCC diagnostic push") \
_Pragma ("GCC diagnostic ignored \"-Wuninitialized\"") \
_Pragma ("GCC diagnostic ignored \"-Wmaybe-uninitialized\"")
# endif
# define YY_IGNORE_MAYBE_UNINITIALIZED_END \
_Pragma ("GCC diagnostic pop")
#else
# define YY_INITIAL_VALUE(Value) Value
#endif
#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
# define YY_IGNORE_MAYBE_UNINITIALIZED_END
#endif
#ifndef YY_INITIAL_VALUE
# define YY_INITIAL_VALUE(Value) /* Nothing. */
#endif
#if defined __cplusplus && defined __GNUC__ && ! defined __ICC && 6 <= __GNUC__
# define YY_IGNORE_USELESS_CAST_BEGIN \
_Pragma ("GCC diagnostic push") \
_Pragma ("GCC diagnostic ignored \"-Wuseless-cast\"")
# define YY_IGNORE_USELESS_CAST_END \
_Pragma ("GCC diagnostic pop")
#endif
#ifndef YY_IGNORE_USELESS_CAST_BEGIN
# define YY_IGNORE_USELESS_CAST_BEGIN
# define YY_IGNORE_USELESS_CAST_END
#endif
#define YY_ASSERT(E) ((void) (0 && (E)))
#if !defined yyoverflow
/* The parser invokes alloca or malloc; define the necessary symbols. */
# ifdef YYSTACK_USE_ALLOCA
# if YYSTACK_USE_ALLOCA
# ifdef __GNUC__
# define YYSTACK_ALLOC __builtin_alloca
|
| ︙ | ︙ | |||
486 487 488 489 490 491 492 | # ifndef YYFREE # define YYFREE free # if ! defined free && ! defined EXIT_SUCCESS void free (void *); /* INFRINGES ON USER NAME SPACE */ # endif # endif # endif | < | | | > | | | | | | | | | | | < < | | > > > | > | > | | | | | | | | > | > | | | | | > > > | > > > > | | | | | > | | < < < < | > < < < < > > | | | | | | | | | | | | | | | | > > | | | | | | | > | | | | | | | > | < > > | | | > | | | | | > | | | | | < > | | | < < < < < < < < | > > > > | | > > > > > | | | | | | | > | | < < < < < > > > > > > | | < < | | | | > > > > | | | > | | | | > > > < < > | | | | | | | | | | | | | | | | > | < | < | 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 |
# ifndef YYFREE
# define YYFREE free
# if ! defined free && ! defined EXIT_SUCCESS
void free (void *); /* INFRINGES ON USER NAME SPACE */
# endif
# endif
# endif
#endif /* !defined yyoverflow */
#if (! defined yyoverflow \
&& (! defined __cplusplus \
|| (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \
&& defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL)))
/* A type that is properly aligned for any stack member. */
union yyalloc
{
yy_state_t yyss_alloc;
YYSTYPE yyvs_alloc;
YYLTYPE yyls_alloc;
};
/* The size of the maximum gap between one aligned stack and the next. */
# define YYSTACK_GAP_MAXIMUM (YYSIZEOF (union yyalloc) - 1)
/* The size of an array large to enough to hold all stacks, each with
N elements. */
# define YYSTACK_BYTES(N) \
((N) * (YYSIZEOF (yy_state_t) + YYSIZEOF (YYSTYPE) \
+ YYSIZEOF (YYLTYPE)) \
+ 2 * YYSTACK_GAP_MAXIMUM)
# define YYCOPY_NEEDED 1
/* Relocate STACK from its old location to the new one. The
local variables YYSIZE and YYSTACKSIZE give the old and new number of
elements in the stack, and YYPTR gives the new location of the
stack. Advance YYPTR to a properly aligned location for the next
stack. */
# define YYSTACK_RELOCATE(Stack_alloc, Stack) \
do \
{ \
YYPTRDIFF_T yynewbytes; \
YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \
Stack = &yyptr->Stack_alloc; \
yynewbytes = yystacksize * YYSIZEOF (*Stack) + YYSTACK_GAP_MAXIMUM; \
yyptr += yynewbytes / YYSIZEOF (*yyptr); \
} \
while (0)
#endif
#if defined YYCOPY_NEEDED && YYCOPY_NEEDED
/* Copy COUNT objects from SRC to DST. The source and destination do
not overlap. */
# ifndef YYCOPY
# if defined __GNUC__ && 1 < __GNUC__
# define YYCOPY(Dst, Src, Count) \
__builtin_memcpy (Dst, Src, YY_CAST (YYSIZE_T, (Count)) * sizeof (*(Src)))
# else
# define YYCOPY(Dst, Src, Count) \
do \
{ \
YYPTRDIFF_T yyi; \
for (yyi = 0; yyi < (Count); yyi++) \
(Dst)[yyi] = (Src)[yyi]; \
} \
while (0)
# endif
# endif
#endif /* !YYCOPY_NEEDED */
/* YYFINAL -- State number of the termination state. */
#define YYFINAL 2
/* YYLAST -- Last index in YYTABLE. */
#define YYLAST 98
/* YYNTOKENS -- Number of terminals. */
#define YYNTOKENS 31
/* YYNNTS -- Number of nonterminals. */
#define YYNNTS 23
/* YYNRULES -- Number of rules. */
#define YYNRULES 72
/* YYNSTATES -- Number of states. */
#define YYNSTATES 103
/* YYMAXUTOK -- Last valid token kind. */
#define YYMAXUTOK 278
/* YYTRANSLATE(TOKEN-NUM) -- Symbol number corresponding to TOKEN-NUM
as returned by yylex, with out-of-bounds checking. */
#define YYTRANSLATE(YYX) \
(0 <= (YYX) && (YYX) <= YYMAXUTOK \
? YY_CAST (yysymbol_kind_t, yytranslate[YYX]) \
: YYSYMBOL_YYUNDEF)
/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM
as returned by yylex. */
static const yytype_int8 yytranslate[] =
{
0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 30, 25, 26, 29, 27, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 24, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 28, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 1, 2, 3, 4,
5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 20, 21, 22, 23
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_int16 yyrline[] =
{
0, 171, 171, 172, 176, 179, 182, 185, 188, 191,
194, 197, 201, 204, 209, 215, 221, 226, 230, 234,
238, 242, 246, 252, 253, 256, 260, 264, 268, 272,
276, 282, 288, 292, 297, 298, 303, 307, 312, 316,
321, 328, 332, 338, 338, 340, 345, 350, 352, 357,
359, 360, 368, 379, 393, 398, 401, 404, 407, 410,
413, 416, 421, 424, 429, 433, 437, 443, 446, 449,
454, 472, 475
};
#endif
/** Accessing symbol of state STATE. */
#define YY_ACCESSING_SYMBOL(State) YY_CAST (yysymbol_kind_t, yystos[State])
#if YYDEBUG || 0
/* The user-facing name of the symbol whose (internal) number is
YYSYMBOL. No bounds checking. */
static const char *yysymbol_name (yysymbol_kind_t yysymbol) YY_ATTRIBUTE_UNUSED;
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
{
"\"end of file\"", "error", "\"invalid token\"", "tAGO", "tDAY",
"tDAYZONE", "tID", "tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE",
"tSEC_UNIT", "tUNUMBER", "tZONE", "tZONEwO4", "tZONEwO2", "tEPOCH",
"tDST", "tISOBAS8", "tISOBAS6", "tISOBASL", "tDAY_UNIT", "tNEXT", "SP",
"':'", "','", "'-'", "'/'", "'T'", "'.'", "'+'", "$accept", "spec",
"item", "iextime", "time", "zone", "comma", "day", "iexdate", "date",
"ordMonth", "isosep", "isodate", "isotime", "iso", "trek", "relspec",
"relunits", "sign", "unit", "INTNUM", "numitem", "o_merid", YY_NULLPTR
};
static const char *
yysymbol_name (yysymbol_kind_t yysymbol)
{
return yytname[yysymbol];
}
#endif
#define YYPACT_NINF (-21)
#define yypact_value_is_default(Yyn) \
((Yyn) == YYPACT_NINF)
#define YYTABLE_NINF (-68)
#define yytable_value_is_error(Yyn) \
0
/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
STATE-NUM. */
static const yytype_int8 yypact[] =
{
-21, 11, -21, -20, -21, 5, -21, -9, -21, 46,
17, 9, 9, -21, -21, -21, 24, -21, 57, -21,
-21, -21, 33, -21, -21, -21, -21, -21, -21, -15,
-21, -21, -21, 45, 26, -21, -7, -21, 51, -21,
-20, -21, -21, -21, 48, -21, -21, 67, 68, 52,
69, -21, -9, -9, -21, -21, -21, -21, 74, -21,
-7, -21, -21, -21, -21, 44, -21, 79, 40, -7,
-21, -21, 72, 73, -21, 62, 61, 63, 64, -21,
-21, -21, -21, 66, -21, -21, -21, -21, 84, -7,
-21, -21, -21, 80, 81, 82, 83, -21, -21, -21,
-21, -21, -21
};
/* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM.
Performed when YYTABLE does not specify something else to do. Zero
means the default is an error. */
static const yytype_int8 yydefact[] =
{
2, 0, 1, 25, 19, 0, 66, 0, 64, 70,
18, 0, 0, 39, 45, 46, 0, 65, 0, 62,
63, 3, 71, 4, 5, 8, 47, 6, 7, 34,
10, 11, 9, 55, 0, 61, 0, 12, 23, 26,
36, 67, 69, 68, 0, 27, 15, 38, 0, 0,
0, 17, 0, 0, 52, 51, 30, 41, 67, 59,
0, 72, 16, 44, 43, 0, 54, 67, 0, 22,
58, 24, 0, 0, 40, 14, 0, 0, 32, 20,
21, 42, 60, 0, 48, 49, 50, 29, 67, 0,
57, 37, 53, 0, 0, 0, 0, 28, 56, 13,
35, 31, 33
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int8 yypgoto[] =
{
-21, -21, -21, 31, -21, -21, 58, -21, -21, -21,
-21, -21, -21, -21, -21, -21, -21, -21, -5, -18,
-6, -21, -21
};
/* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int8 yydefgoto[] =
{
0, 1, 21, 22, 23, 24, 39, 25, 26, 27,
28, 65, 29, 86, 30, 31, 32, 33, 34, 35,
36, 37, 62
};
/* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If
positive, shift that token. If negative, reduce the rule whose
number is the opposite. If YYTABLE_NINF, syntax error. */
static const yytype_int8 yytable[] =
{
59, 44, 6, 41, 8, 38, 52, 53, 63, 42,
43, 2, 60, 64, 17, 3, 4, 40, 70, 5,
6, 7, 8, 9, 10, 11, 12, 13, 69, 14,
15, 16, 17, 18, 51, 19, 54, 19, 67, 20,
61, 20, 82, 55, 42, 43, 79, 80, 66, 68,
45, 90, 88, 46, 47, -67, 83, -67, 42, 43,
76, 56, 89, 84, 77, 57, 6, -67, 8, 58,
48, 98, 49, 50, 71, 42, 43, 73, 17, 74,
75, 78, 81, 87, 91, 92, 93, 94, 97, 95,
48, 96, 99, 100, 101, 102, 85, 0, 72
};
static const yytype_int8 yycheck[] =
{
18, 7, 9, 12, 11, 25, 11, 12, 23, 18,
19, 0, 18, 28, 21, 4, 5, 12, 36, 8,
9, 10, 11, 12, 13, 14, 15, 16, 34, 18,
19, 20, 21, 22, 17, 26, 12, 26, 12, 30,
7, 30, 60, 19, 18, 19, 52, 53, 3, 23,
4, 69, 12, 7, 8, 9, 12, 11, 18, 19,
8, 4, 68, 19, 12, 8, 9, 21, 11, 12,
24, 89, 26, 27, 23, 18, 19, 29, 21, 12,
12, 12, 8, 4, 12, 12, 24, 26, 4, 26,
24, 27, 12, 12, 12, 12, 65, -1, 40
};
/* YYSTOS[STATE-NUM] -- The symbol kind of the accessing symbol of
state STATE-NUM. */
static const yytype_int8 yystos[] =
{
0, 32, 0, 4, 5, 8, 9, 10, 11, 12,
13, 14, 15, 16, 18, 19, 20, 21, 22, 26,
30, 33, 34, 35, 36, 38, 39, 40, 41, 43,
45, 46, 47, 48, 49, 50, 51, 52, 25, 37,
12, 12, 18, 19, 51, 4, 7, 8, 24, 26,
27, 17, 49, 49, 12, 19, 4, 8, 12, 50,
51, 7, 53, 23, 28, 42, 3, 12, 23, 51,
50, 23, 37, 29, 12, 12, 8, 12, 12, 51,
51, 8, 50, 12, 19, 34, 44, 4, 12, 51,
50, 12, 12, 24, 26, 26, 27, 4, 50, 12,
12, 12, 12
};
/* YYR1[RULE-NUM] -- Symbol kind of the left-hand side of rule RULE-NUM. */
static const yytype_int8 yyr1[] =
{
0, 31, 32, 32, 33, 33, 33, 33, 33, 33,
33, 33, 33, 34, 34, 35, 35, 36, 36, 36,
36, 36, 36, 37, 37, 38, 38, 38, 38, 38,
38, 39, 40, 40, 40, 40, 40, 40, 40, 40,
40, 41, 41, 42, 42, 43, 43, 43, 44, 44,
45, 45, 45, 46, 47, 47, 48, 48, 48, 48,
48, 48, 49, 49, 50, 50, 50, 51, 51, 51,
52, 53, 53
};
/* YYR2[RULE-NUM] -- Number of symbols on the right-hand side of rule RULE-NUM. */
static const yytype_int8 yyr2[] =
{
0, 2, 0, 2, 1, 1, 1, 1, 1, 1,
1, 1, 1, 5, 3, 2, 2, 2, 1, 1,
3, 3, 2, 1, 2, 1, 2, 2, 4, 3,
2, 5, 3, 5, 1, 5, 2, 4, 2, 1,
3, 2, 3, 1, 1, 1, 1, 1, 1, 1,
3, 2, 2, 4, 2, 1, 4, 3, 2, 2,
3, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 0, 1
};
enum { YYENOMEM = -2 };
#define yyerrok (yyerrstatus = 0)
#define yyclearin (yychar = YYEMPTY)
#define YYACCEPT goto yyacceptlab
#define YYABORT goto yyabortlab
#define YYERROR goto yyerrorlab
#define YYNOMEM goto yyexhaustedlab
#define YYRECOVERING() (!!yyerrstatus)
#define YYBACKUP(Token, Value) \
do \
if (yychar == YYEMPTY) \
{ \
yychar = (Token); \
yylval = (Value); \
YYPOPSTACK (yylen); \
yystate = *yyssp; \
goto yybackup; \
} \
else \
{ \
yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \
YYERROR; \
} \
while (0)
/* Backward compatibility with an undocumented macro.
Use YYerror or YYUNDEF. */
#define YYERRCODE YYUNDEF
/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N].
If N is 0, then set CURRENT to the empty location which ends
the previous symbol: RHS[0] (always defined). */
#ifndef YYLLOC_DEFAULT
# define YYLLOC_DEFAULT(Current, Rhs, N) \
|
| ︙ | ︙ | |||
844 845 846 847 848 849 850 |
# define YYDPRINTF(Args) \
do { \
if (yydebug) \
YYFPRINTF Args; \
} while (0)
| | > > | > > > > > | | | | | | > > > | > | > > > | | > | | | | | > | | | | | < | < < | > | | | > | | | | | | | | | 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 |
# define YYDPRINTF(Args) \
do { \
if (yydebug) \
YYFPRINTF Args; \
} while (0)
/* YYLOCATION_PRINT -- Print the location on the stream.
This macro was not mandated originally: define only if we know
we won't break user code: when these are the locations we know. */
# ifndef YYLOCATION_PRINT
# if defined YY_LOCATION_PRINT
/* Temporary convenience wrapper in case some people defined the
undocumented and private YY_LOCATION_PRINT macros. */
# define YYLOCATION_PRINT(File, Loc) YY_LOCATION_PRINT(File, *(Loc))
# elif defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL
/* Print *YYLOCP on YYO. Private, do not rely on its existence. */
YY_ATTRIBUTE_UNUSED
static int
yy_location_print_ (FILE *yyo, YYLTYPE const * const yylocp)
{
int res = 0;
int end_col = 0 != yylocp->last_column ? yylocp->last_column - 1 : 0;
if (0 <= yylocp->first_line)
{
res += YYFPRINTF (yyo, "%d", yylocp->first_line);
if (0 <= yylocp->first_column)
res += YYFPRINTF (yyo, ".%d", yylocp->first_column);
}
if (0 <= yylocp->last_line)
{
if (yylocp->first_line < yylocp->last_line)
{
res += YYFPRINTF (yyo, "-%d", yylocp->last_line);
if (0 <= end_col)
res += YYFPRINTF (yyo, ".%d", end_col);
}
else if (0 <= end_col && yylocp->first_column < end_col)
res += YYFPRINTF (yyo, "-%d", end_col);
}
return res;
}
# define YYLOCATION_PRINT yy_location_print_
/* Temporary convenience wrapper in case some people defined the
undocumented and private YY_LOCATION_PRINT macros. */
# define YY_LOCATION_PRINT(File, Loc) YYLOCATION_PRINT(File, &(Loc))
# else
# define YYLOCATION_PRINT(File, Loc) ((void) 0)
/* Temporary convenience wrapper in case some people defined the
undocumented and private YY_LOCATION_PRINT macros. */
# define YY_LOCATION_PRINT YYLOCATION_PRINT
# endif
# endif /* !defined YYLOCATION_PRINT */
# define YY_SYMBOL_PRINT(Title, Kind, Value, Location) \
do { \
if (yydebug) \
{ \
YYFPRINTF (stderr, "%s ", Title); \
yy_symbol_print (stderr, \
Kind, Value, Location, info); \
YYFPRINTF (stderr, "\n"); \
} \
} while (0)
/*-----------------------------------.
| Print this symbol's value on YYO. |
`-----------------------------------*/
static void
yy_symbol_value_print (FILE *yyo,
yysymbol_kind_t yykind, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
{
FILE *yyoutput = yyo;
YY_USE (yyoutput);
YY_USE (yylocationp);
YY_USE (info);
if (!yyvaluep)
return;
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
YY_USE (yykind);
YY_IGNORE_MAYBE_UNINITIALIZED_END
}
/*---------------------------.
| Print this symbol on YYO. |
`---------------------------*/
static void
yy_symbol_print (FILE *yyo,
yysymbol_kind_t yykind, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
{
YYFPRINTF (yyo, "%s %s (",
yykind < YYNTOKENS ? "token" : "nterm", yysymbol_name (yykind));
YYLOCATION_PRINT (yyo, yylocationp);
YYFPRINTF (yyo, ": ");
yy_symbol_value_print (yyo, yykind, yyvaluep, yylocationp, info);
YYFPRINTF (yyo, ")");
}
/*------------------------------------------------------------------.
| yy_stack_print -- Print the state stack from its BOTTOM up to its |
| TOP (included). |
`------------------------------------------------------------------*/
static void
yy_stack_print (yy_state_t *yybottom, yy_state_t *yytop)
{
YYFPRINTF (stderr, "Stack now");
for (; yybottom <= yytop; yybottom++)
{
int yybot = *yybottom;
YYFPRINTF (stderr, " %d", yybot);
}
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 | /*------------------------------------------------. | Report that the YYRULE is going to be reduced. | `------------------------------------------------*/ static void | | > | | | | | | | | 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 |
/*------------------------------------------------.
| Report that the YYRULE is going to be reduced. |
`------------------------------------------------*/
static void
yy_reduce_print (yy_state_t *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp,
int yyrule, DateInfo* info)
{
int yylno = yyrline[yyrule];
int yynrhs = yyr2[yyrule];
int yyi;
YYFPRINTF (stderr, "Reducing stack by rule %d (line %d):\n",
yyrule - 1, yylno);
/* The symbols being reduced. */
for (yyi = 0; yyi < yynrhs; yyi++)
{
YYFPRINTF (stderr, " $%d = ", yyi + 1);
yy_symbol_print (stderr,
YY_ACCESSING_SYMBOL (+yyssp[yyi + 1 - yynrhs]),
&yyvsp[(yyi + 1) - (yynrhs)],
&(yylsp[(yyi + 1) - (yynrhs)]), info);
YYFPRINTF (stderr, "\n");
}
}
# define YY_REDUCE_PRINT(Rule) \
do { \
if (yydebug) \
yy_reduce_print (yyssp, yyvsp, yylsp, Rule, info); \
} while (0)
/* Nonzero means print parse trace. It is left uninitialized so that
multiple parsers can coexist. */
int yydebug;
#else /* !YYDEBUG */
# define YYDPRINTF(Args) ((void) 0)
# define YY_SYMBOL_PRINT(Title, Kind, Value, Location)
# define YY_STACK_PRINT(Bottom, Top)
# define YY_REDUCE_PRINT(Rule)
#endif /* !YYDEBUG */
/* YYINITDEPTH -- initial size of the parser's stacks. */
#ifndef YYINITDEPTH
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 | evaluated with infinite-precision integer arithmetic. */ #ifndef YYMAXDEPTH # define YYMAXDEPTH 10000 #endif | < < < < < < < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | | | | | > > | > > > | | < < < < < | > > > | | | | | | | | | | < < < < < > | | | < | | | < < < < < < < < > > | | > > > > | > > > | > > > > > | | > < | | | < < > < | < < < > | | > < > < > | | > > < > < | | | > > > > > > > > > > > > | 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 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 |
evaluated with infinite-precision integer arithmetic. */
#ifndef YYMAXDEPTH
# define YYMAXDEPTH 10000
#endif
/*-----------------------------------------------.
| Release the memory associated to this symbol. |
`-----------------------------------------------*/
static void
yydestruct (const char *yymsg,
yysymbol_kind_t yykind, YYSTYPE *yyvaluep, YYLTYPE *yylocationp, DateInfo* info)
{
YY_USE (yyvaluep);
YY_USE (yylocationp);
YY_USE (info);
if (!yymsg)
yymsg = "Deleting";
YY_SYMBOL_PRINT (yymsg, yykind, yyvaluep, yylocationp);
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
YY_USE (yykind);
YY_IGNORE_MAYBE_UNINITIALIZED_END
}
/*----------.
| yyparse. |
`----------*/
int
yyparse (DateInfo* info)
{
/* Lookahead token kind. */
int yychar;
/* The semantic value of the lookahead symbol. */
/* Default value used for initialization, for pacifying older GCCs
or non-GCC compilers. */
YY_INITIAL_VALUE (static YYSTYPE yyval_default;)
YYSTYPE yylval YY_INITIAL_VALUE (= yyval_default);
/* Location data for the lookahead symbol. */
static YYLTYPE yyloc_default
# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL
= { 1, 1, 1, 1 }
# endif
;
YYLTYPE yylloc = yyloc_default;
/* Number of syntax errors so far. */
int yynerrs = 0;
yy_state_fast_t yystate = 0;
/* Number of tokens to shift before error messages enabled. */
int yyerrstatus = 0;
/* Refer to the stacks through separate pointers, to allow yyoverflow
to reallocate them elsewhere. */
/* Their size. */
YYPTRDIFF_T yystacksize = YYINITDEPTH;
/* The state stack: array, bottom, top. */
yy_state_t yyssa[YYINITDEPTH];
yy_state_t *yyss = yyssa;
yy_state_t *yyssp = yyss;
/* The semantic value stack: array, bottom, top. */
YYSTYPE yyvsa[YYINITDEPTH];
YYSTYPE *yyvs = yyvsa;
YYSTYPE *yyvsp = yyvs;
/* The location stack: array, bottom, top. */
YYLTYPE yylsa[YYINITDEPTH];
YYLTYPE *yyls = yylsa;
YYLTYPE *yylsp = yyls;
int yyn;
/* The return value of yyparse. */
int yyresult;
/* Lookahead symbol kind. */
yysymbol_kind_t yytoken = YYSYMBOL_YYEMPTY;
/* The variables used to return semantic value and location from the
action routines. */
YYSTYPE yyval;
YYLTYPE yyloc;
/* The locations where the error started and ended. */
YYLTYPE yyerror_range[3];
#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N))
/* The number of symbols on the RHS of the reduced rule.
Keep to zero when no symbol should be popped. */
int yylen = 0;
YYDPRINTF ((stderr, "Starting parse\n"));
yychar = YYEMPTY; /* Cause a token to be read. */
yylsp[0] = yylloc;
goto yysetstate;
/*------------------------------------------------------------.
| yynewstate -- push a new state, which is found in yystate. |
`------------------------------------------------------------*/
yynewstate:
/* In all cases, when you get here, the value and location stacks
have just been pushed. So pushing a state here evens the stacks. */
yyssp++;
/*--------------------------------------------------------------------.
| yysetstate -- set current state (the top of the stack) to yystate. |
`--------------------------------------------------------------------*/
yysetstate:
YYDPRINTF ((stderr, "Entering state %d\n", yystate));
YY_ASSERT (0 <= yystate && yystate < YYNSTATES);
YY_IGNORE_USELESS_CAST_BEGIN
*yyssp = YY_CAST (yy_state_t, yystate);
YY_IGNORE_USELESS_CAST_END
YY_STACK_PRINT (yyss, yyssp);
if (yyss + yystacksize - 1 <= yyssp)
#if !defined yyoverflow && !defined YYSTACK_RELOCATE
YYNOMEM;
#else
{
/* Get the current used size of the three stacks, in elements. */
YYPTRDIFF_T yysize = yyssp - yyss + 1;
# if defined yyoverflow
{
/* Give user a chance to reallocate the stack. Use copies of
these so that the &'s don't force the real ones into
memory. */
yy_state_t *yyss1 = yyss;
YYSTYPE *yyvs1 = yyvs;
YYLTYPE *yyls1 = yyls;
/* Each stack pointer address is followed by the size of the
data in use in that stack, in bytes. This used to be a
conditional around just the two extra args, but that might
be undefined if yyoverflow is a macro. */
yyoverflow (YY_("memory exhausted"),
&yyss1, yysize * YYSIZEOF (*yyssp),
&yyvs1, yysize * YYSIZEOF (*yyvsp),
&yyls1, yysize * YYSIZEOF (*yylsp),
&yystacksize);
yyss = yyss1;
yyvs = yyvs1;
yyls = yyls1;
}
# else /* defined YYSTACK_RELOCATE */
/* Extend the stack our own way. */
if (YYMAXDEPTH <= yystacksize)
YYNOMEM;
yystacksize *= 2;
if (YYMAXDEPTH < yystacksize)
yystacksize = YYMAXDEPTH;
{
yy_state_t *yyss1 = yyss;
union yyalloc *yyptr =
YY_CAST (union yyalloc *,
YYSTACK_ALLOC (YY_CAST (YYSIZE_T, YYSTACK_BYTES (yystacksize))));
if (! yyptr)
YYNOMEM;
YYSTACK_RELOCATE (yyss_alloc, yyss);
YYSTACK_RELOCATE (yyvs_alloc, yyvs);
YYSTACK_RELOCATE (yyls_alloc, yyls);
# undef YYSTACK_RELOCATE
if (yyss1 != yyssa)
YYSTACK_FREE (yyss1);
}
# endif
yyssp = yyss + yysize - 1;
yyvsp = yyvs + yysize - 1;
yylsp = yyls + yysize - 1;
YY_IGNORE_USELESS_CAST_BEGIN
YYDPRINTF ((stderr, "Stack size increased to %ld\n",
YY_CAST (long, yystacksize)));
YY_IGNORE_USELESS_CAST_END
if (yyss + yystacksize - 1 <= yyssp)
YYABORT;
}
#endif /* !defined yyoverflow && !defined YYSTACK_RELOCATE */
if (yystate == YYFINAL)
YYACCEPT;
goto yybackup;
/*-----------.
| yybackup. |
`-----------*/
yybackup:
/* Do appropriate processing given the current state. Read a
lookahead token if we need one and don't already have one. */
/* First try to decide what to do without reference to lookahead token. */
yyn = yypact[yystate];
if (yypact_value_is_default (yyn))
goto yydefault;
/* Not known => get a lookahead token if don't already have one. */
/* YYCHAR is either empty, or end-of-input, or a valid lookahead. */
if (yychar == YYEMPTY)
{
YYDPRINTF ((stderr, "Reading a token\n"));
yychar = yylex (&yylval, &yylloc, info);
}
if (yychar <= YYEOF)
{
yychar = YYEOF;
yytoken = YYSYMBOL_YYEOF;
YYDPRINTF ((stderr, "Now at end of input.\n"));
}
else if (yychar == YYerror)
{
/* The scanner already issued an error message, process directly
to error recovery. But do not keep the error token as
lookahead, it is too special and may lead us to an endless
loop in error recovery. */
yychar = YYUNDEF;
yytoken = YYSYMBOL_YYerror;
yyerror_range[1] = yylloc;
goto yyerrlab1;
}
else
{
yytoken = YYTRANSLATE (yychar);
YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc);
}
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 |
/* Count tokens shifted since error; after three, turn off error
status. */
if (yyerrstatus)
yyerrstatus--;
/* Shift the lookahead token. */
YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
| < < < < > > > | | 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
/* Count tokens shifted since error; after three, turn off error
status. */
if (yyerrstatus)
yyerrstatus--;
/* Shift the lookahead token. */
YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
yystate = yyn;
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
YY_IGNORE_MAYBE_UNINITIALIZED_END
*++yylsp = yylloc;
/* Discard the shifted token. */
yychar = YYEMPTY;
goto yynewstate;
/*-----------------------------------------------------------.
| yydefault -- do the default action for the current state. |
`-----------------------------------------------------------*/
yydefault:
yyn = yydefact[yystate];
if (yyn == 0)
goto yyerrlab;
goto yyreduce;
/*-----------------------------.
| yyreduce -- do a reduction. |
`-----------------------------*/
yyreduce:
/* yyn is the number of a rule to reduce with. */
yylen = yyr2[yyn];
/* If YYLEN is nonzero, implement the default value of the action:
'$$ = $1'.
|
| ︙ | ︙ | |||
1539 1540 1541 1542 1543 1544 1545 |
/* Default location. */
YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen);
yyerror_range[1] = yyloc;
YY_REDUCE_PRINT (yyn);
switch (yyn)
{
| | | < | < | | < | < | | < | < | | < < > < | | > > > | > > > > > < | > | > > < | | < > > < < | | | > | < | | < | | | < | | < < | | < < < < < | | < < < | | < | | > > > > | > > | < < | | < | < < | | < | | < | | < < | | < | < | | < | < | | < | > > > > > > | | < | < < | | | > > > > > > > < | | < < | | < < | | < < < < < < < < < < < < < < < < < < < < < | | < < < | | < | | < < | | < < < | | < < | | | | < < | | | | < < < > | < | | | > > | > > | > | < < | | < < < < < < | < < < < < < < < < | < < < < < > > > > > > > > > > > < | | | < < | | < < | | | < < | | | < < | | | < < | | | > > | > | > > < | | < < | | < < | | < < | | < < | | < < | | > > > > > | | > > > | > > > > > | > > > | < < | | < < | | < | < | | | < | | < | > | < < < < < < < < < < < < < < < < < | < < < < < < < < < < < | < < | < < | < < | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 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 |
/* Default location. */
YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen);
yyerror_range[1] = yyloc;
YY_REDUCE_PRINT (yyn);
switch (yyn)
{
case 4: /* item: time */
{
yyIncrFlags(CLF_TIME);
}
break;
case 5: /* item: zone */
{
yyIncrFlags(CLF_ZONE);
}
break;
case 6: /* item: date */
{
yyIncrFlags(CLF_HAVEDATE);
}
break;
case 7: /* item: ordMonth */
{
yyIncrFlags(CLF_ORDINALMONTH);
}
break;
case 8: /* item: day */
{
yyIncrFlags(CLF_DAYOFWEEK);
}
break;
case 9: /* item: relspec */
{
info->flags |= CLF_RELCONV;
}
break;
case 10: /* item: iso */
{
yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
}
break;
case 11: /* item: trek */
{
yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
info->flags |= CLF_RELCONV;
}
break;
case 13: /* iextime: tUNUMBER ':' tUNUMBER ':' tUNUMBER */
{
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yySeconds = (yyvsp[0].Number);
}
break;
case 14: /* iextime: tUNUMBER ':' tUNUMBER */
{
yyHour = (yyvsp[-2].Number);
yyMinutes = (yyvsp[0].Number);
yySeconds = 0;
}
break;
case 15: /* time: tUNUMBER tMERIDIAN */
{
yyHour = (yyvsp[-1].Number);
yyMinutes = 0;
yySeconds = 0;
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 16: /* time: iextime o_merid */
{
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 17: /* zone: tZONE tDST */
{
yyTimezone = (yyvsp[-1].Number);
yyDSTmode = DSTon;
}
break;
case 18: /* zone: tZONE */
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSToff;
}
break;
case 19: /* zone: tDAYZONE */
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSTon;
}
break;
case 20: /* zone: tZONEwO4 sign INTNUM */
{ /* GMT+0100, GMT-1000, etc. */
yyTimezone = (yyvsp[-2].Number) - (yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
yyDSTmode = DSToff;
}
break;
case 21: /* zone: tZONEwO2 sign INTNUM */
{ /* GMT+1, GMT-10, etc. */
yyTimezone = (yyvsp[-2].Number) - (yyvsp[-1].Number)*((yyvsp[0].Number) * 60);
yyDSTmode = DSToff;
}
break;
case 22: /* zone: sign INTNUM */
{ /* +0100, -0100 */
yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
yyDSTmode = DSToff;
}
break;
case 25: /* day: tDAY */
{
yyDayOrdinal = 1;
yyDayOfWeek = (yyvsp[0].Number);
}
break;
case 26: /* day: tDAY comma */
{
yyDayOrdinal = 1;
yyDayOfWeek = (yyvsp[-1].Number);
}
break;
case 27: /* day: tUNUMBER tDAY */
{
yyDayOrdinal = (yyvsp[-1].Number);
yyDayOfWeek = (yyvsp[0].Number);
}
break;
case 28: /* day: sign SP tUNUMBER tDAY */
{
yyDayOrdinal = (yyvsp[-3].Number) * (yyvsp[-1].Number);
yyDayOfWeek = (yyvsp[0].Number);
}
break;
case 29: /* day: sign tUNUMBER tDAY */
{
yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number);
yyDayOfWeek = (yyvsp[0].Number);
}
break;
case 30: /* day: tNEXT tDAY */
{
yyDayOrdinal = 2;
yyDayOfWeek = (yyvsp[0].Number);
}
break;
case 31: /* iexdate: tUNUMBER '-' tUNUMBER '-' tUNUMBER */
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
yyYear = (yyvsp[-4].Number);
}
break;
case 32: /* date: tUNUMBER '/' tUNUMBER */
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 33: /* date: tUNUMBER '/' tUNUMBER '/' tUNUMBER */
{
yyMonth = (yyvsp[-4].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 35: /* date: tUNUMBER '-' tMONTH '-' tUNUMBER */
{
yyDay = (yyvsp[-4].Number);
yyMonth = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 36: /* date: tMONTH tUNUMBER */
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 37: /* date: tMONTH tUNUMBER comma tUNUMBER */
{
yyMonth = (yyvsp[-3].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 38: /* date: tUNUMBER tMONTH */
{
yyMonth = (yyvsp[0].Number);
yyDay = (yyvsp[-1].Number);
}
break;
case 39: /* date: tEPOCH */
{
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
break;
case 40: /* date: tUNUMBER tMONTH tUNUMBER */
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 41: /* ordMonth: tNEXT tMONTH */
{
yyMonthOrdinalIncr = 1;
yyMonthOrdinal = (yyvsp[0].Number);
}
break;
case 42: /* ordMonth: tNEXT tUNUMBER tMONTH */
{
yyMonthOrdinalIncr = (yyvsp[-1].Number);
yyMonthOrdinal = (yyvsp[0].Number);
}
break;
case 45: /* isodate: tISOBAS8 */
{ /* YYYYMMDD */
yyYear = (yyvsp[0].Number) / 10000;
yyMonth = ((yyvsp[0].Number) % 10000)/100;
yyDay = (yyvsp[0].Number) % 100;
}
break;
case 46: /* isodate: tISOBAS6 */
{ /* YYMMDD */
yyYear = (yyvsp[0].Number) / 10000;
yyMonth = ((yyvsp[0].Number) % 10000)/100;
yyDay = (yyvsp[0].Number) % 100;
}
break;
case 48: /* isotime: tISOBAS6 */
{
yyHour = (yyvsp[0].Number) / 10000;
yyMinutes = ((yyvsp[0].Number) % 10000)/100;
yySeconds = (yyvsp[0].Number) % 100;
}
break;
case 51: /* iso: tISOBASL tISOBAS6 */
{ /* YYYYMMDDhhmmss */
yyYear = (yyvsp[-1].Number) / 10000;
yyMonth = ((yyvsp[-1].Number) % 10000)/100;
yyDay = (yyvsp[-1].Number) % 100;
yyHour = (yyvsp[0].Number) / 10000;
yyMinutes = ((yyvsp[0].Number) % 10000)/100;
yySeconds = (yyvsp[0].Number) % 100;
}
break;
case 52: /* iso: tISOBASL tUNUMBER */
{ /* YYYYMMDDhhmm */
if (yyDigitCount != 4) YYABORT; /* normally unreached */
yyYear = (yyvsp[-1].Number) / 10000;
yyMonth = ((yyvsp[-1].Number) % 10000)/100;
yyDay = (yyvsp[-1].Number) % 100;
yyHour = (yyvsp[0].Number) / 100;
yyMinutes = ((yyvsp[0].Number) % 100);
yySeconds = 0;
}
break;
case 53: /* trek: tSTARDATE INTNUM '.' tUNUMBER */
{
/*
* Offset computed year by -377 so that the returned years will be
* in a range accessible with a 32 bit clock seconds value.
*/
yyYear = (yyvsp[-2].Number)/1000 + 2323 - 377;
yyDay = 1;
yyMonth = 1;
yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000;
yyRelSeconds += (yyvsp[0].Number) * (144LL * 60LL);
}
break;
case 54: /* relspec: relunits tAGO */
{
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
}
break;
case 56: /* relunits: sign SP INTNUM unit */
{
*yyRelPointer += (yyvsp[-3].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 57: /* relunits: sign INTNUM unit */
{
*yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 58: /* relunits: INTNUM unit */
{
*yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 59: /* relunits: tNEXT unit */
{
*yyRelPointer += (yyvsp[0].Number);
}
break;
case 60: /* relunits: tNEXT INTNUM unit */
{
*yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 61: /* relunits: unit */
{
*yyRelPointer += (yyvsp[0].Number);
}
break;
case 62: /* sign: '-' */
{
(yyval.Number) = -1;
}
break;
case 63: /* sign: '+' */
{
(yyval.Number) = 1;
}
break;
case 64: /* unit: tSEC_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelSeconds;
}
break;
case 65: /* unit: tDAY_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelDay;
}
break;
case 66: /* unit: tMONTH_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelMonth;
}
break;
case 67: /* INTNUM: tUNUMBER */
{
(yyval.Number) = (yyvsp[0].Number);
}
break;
case 68: /* INTNUM: tISOBAS6 */
{
(yyval.Number) = (yyvsp[0].Number);
}
break;
case 69: /* INTNUM: tISOBAS8 */
{
(yyval.Number) = (yyvsp[0].Number);
}
break;
case 70: /* numitem: tUNUMBER */
{
if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_RELCONV)) == (CLF_TIME|CLF_HAVEDATE)) {
yyYear = (yyvsp[0].Number);
} else {
yyIncrFlags(CLF_TIME);
if (yyDigitCount <= 2) {
yyHour = (yyvsp[0].Number);
yyMinutes = 0;
} else {
yyHour = (yyvsp[0].Number) / 100;
yyMinutes = (yyvsp[0].Number) % 100;
}
yySeconds = 0;
yyMeridian = MER24;
}
}
break;
case 71: /* o_merid: %empty */
{
(yyval.Meridian) = MER24;
}
break;
case 72: /* o_merid: tMERIDIAN */
{
(yyval.Meridian) = (yyvsp[0].Meridian);
}
break;
default: break;
}
/* User semantic actions sometimes alter yychar, and that requires
that yytoken be updated with the new translation. We take the
approach of translating immediately before every use of yytoken.
One alternative is translating here after every semantic action,
but that translation would be missed if the semantic action invokes
YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or
if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an
incorrect destructor might then be invoked immediately. In the
case of YYERROR or YYBACKUP, subsequent parser actions might lead
to an incorrect destructor call or verbose syntax error message
before the lookahead is translated. */
YY_SYMBOL_PRINT ("-> $$ =", YY_CAST (yysymbol_kind_t, yyr1[yyn]), &yyval, &yyloc);
YYPOPSTACK (yylen);
yylen = 0;
*++yyvsp = yyval;
*++yylsp = yyloc;
/* Now 'shift' the result of the reduction. Determine what state
that goes to, based on the state we popped back to and the rule
number reduced by. */
{
const int yylhs = yyr1[yyn] - YYNTOKENS;
const int yyi = yypgoto[yylhs] + *yyssp;
yystate = (0 <= yyi && yyi <= YYLAST && yycheck[yyi] == *yyssp
? yytable[yyi]
: yydefgoto[yylhs]);
}
goto yynewstate;
/*--------------------------------------.
| yyerrlab -- here on detecting error. |
`--------------------------------------*/
yyerrlab:
/* Make sure we have latest lookahead translation. See comments at
user semantic actions for why this is necessary. */
yytoken = yychar == YYEMPTY ? YYSYMBOL_YYEMPTY : YYTRANSLATE (yychar);
/* If not already recovering from an error, report this error. */
if (!yyerrstatus)
{
++yynerrs;
yyerror (&yylloc, info, YY_("syntax error"));
}
yyerror_range[1] = yylloc;
if (yyerrstatus == 3)
{
/* If just tried and failed to reuse lookahead token after an
error, discard it. */
if (yychar <= YYEOF)
{
|
| ︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 | goto yyerrlab1; /*---------------------------------------------------. | yyerrorlab -- error raised explicitly by YYERROR. | `---------------------------------------------------*/ yyerrorlab: | < | | < | > | > | | | < < < | > | | > | | | | | | | > > > | | | < < < | 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 |
goto yyerrlab1;
/*---------------------------------------------------.
| yyerrorlab -- error raised explicitly by YYERROR. |
`---------------------------------------------------*/
yyerrorlab:
/* Pacify compilers when the user code never invokes YYERROR and the
label yyerrorlab therefore never appears in user code. */
if (0)
YYERROR;
++yynerrs;
/* Do not reclaim the symbols of the rule whose action triggered
this YYERROR. */
YYPOPSTACK (yylen);
yylen = 0;
YY_STACK_PRINT (yyss, yyssp);
yystate = *yyssp;
goto yyerrlab1;
/*-------------------------------------------------------------.
| yyerrlab1 -- common code for both syntax error and YYERROR. |
`-------------------------------------------------------------*/
yyerrlab1:
yyerrstatus = 3; /* Each real token shifted decrements this. */
/* Pop stack until we find a state that shifts the error token. */
for (;;)
{
yyn = yypact[yystate];
if (!yypact_value_is_default (yyn))
{
yyn += YYSYMBOL_YYerror;
if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYSYMBOL_YYerror)
{
yyn = yytable[yyn];
if (0 < yyn)
break;
}
}
/* Pop the current state because it cannot handle the error token. */
if (yyssp == yyss)
YYABORT;
yyerror_range[1] = *yylsp;
yydestruct ("Error: popping",
YY_ACCESSING_SYMBOL (yystate), yyvsp, yylsp, info);
YYPOPSTACK (1);
yystate = *yyssp;
YY_STACK_PRINT (yyss, yyssp);
}
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
YY_IGNORE_MAYBE_UNINITIALIZED_END
yyerror_range[2] = yylloc;
++yylsp;
YYLLOC_DEFAULT (*yylsp, yyerror_range, 2);
/* Shift the error token. */
YY_SYMBOL_PRINT ("Shifting", YY_ACCESSING_SYMBOL (yyn), yyvsp, yylsp);
yystate = yyn;
goto yynewstate;
/*-------------------------------------.
| yyacceptlab -- YYACCEPT comes here. |
`-------------------------------------*/
yyacceptlab:
yyresult = 0;
goto yyreturnlab;
/*-----------------------------------.
| yyabortlab -- YYABORT comes here. |
`-----------------------------------*/
yyabortlab:
yyresult = 1;
goto yyreturnlab;
/*-----------------------------------------------------------.
| yyexhaustedlab -- YYNOMEM (memory exhaustion) comes here. |
`-----------------------------------------------------------*/
yyexhaustedlab:
yyerror (&yylloc, info, YY_("memory exhausted"));
yyresult = 2;
goto yyreturnlab;
/*----------------------------------------------------------.
| yyreturnlab -- parsing is finished, clean up and return. |
`----------------------------------------------------------*/
yyreturnlab:
if (yychar != YYEMPTY)
{
/* Make sure we have latest lookahead translation. See comments at
user semantic actions for why this is necessary. */
yytoken = YYTRANSLATE (yychar);
yydestruct ("Cleanup: discarding lookahead",
yytoken, &yylval, &yylloc, info);
}
/* Do not reclaim the symbols of the rule whose action triggered
this YYABORT or YYACCEPT. */
YYPOPSTACK (yylen);
YY_STACK_PRINT (yyss, yyssp);
while (yyssp != yyss)
{
yydestruct ("Cleanup: popping",
YY_ACCESSING_SYMBOL (+*yyssp), yyvsp, yylsp, info);
YYPOPSTACK (1);
}
#ifndef yyoverflow
if (yyss != yyssa)
YYSTACK_FREE (yyss);
#endif
return yyresult;
}
/*
* Month and day table.
*/
|
| ︙ | ︙ | |||
2293 2294 2295 2296 2297 2298 2299 |
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
| | | 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 |
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
{ "sunday", tDAY, 7 },
{ "monday", tDAY, 1 },
{ "tuesday", tDAY, 2 },
{ "tues", tDAY, 2 },
{ "wednesday", tDAY, 3 },
{ "wednes", tDAY, 3 },
{ "thursday", tDAY, 4 },
{ "thur", tDAY, 4 },
|
| ︙ | ︙ | |||
2337 2338 2339 2340 2341 2342 2343 |
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
| < < < < < < < < < < < < < < | 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 |
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0 },
{ NULL, 0, 0 }
};
/*
|
| ︙ | ︙ | |||
2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 |
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
| > > | 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 |
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "akst", tZONE, HOUR( 9) }, /* Alaska Standard */
{ "akdt", tDAYZONE, HOUR( 9) }, /* Alaska Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
|
| ︙ | ︙ | |||
2448 2449 2450 2451 2452 2453 2454 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > | | | | < < < < < < | < | < < < | < < | | | 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) },
{ "b", tZONE, -HOUR( 2) },
{ "c", tZONE, -HOUR( 3) },
{ "d", tZONE, -HOUR( 4) },
{ "e", tZONE, -HOUR( 5) },
{ "f", tZONE, -HOUR( 6) },
{ "g", tZONE, -HOUR( 7) },
{ "h", tZONE, -HOUR( 8) },
{ "i", tZONE, -HOUR( 9) },
{ "k", tZONE, -HOUR(10) },
{ "l", tZONE, -HOUR(11) },
{ "m", tZONE, -HOUR(12) },
{ "n", tZONE, HOUR( 1) },
{ "o", tZONE, HOUR( 2) },
{ "p", tZONE, HOUR( 3) },
{ "q", tZONE, HOUR( 4) },
{ "r", tZONE, HOUR( 5) },
{ "s", tZONE, HOUR( 6) },
{ "t", tZONE, HOUR( 7) },
{ "u", tZONE, HOUR( 8) },
{ "v", tZONE, HOUR( 9) },
{ "w", tZONE, HOUR( 10) },
{ "x", tZONE, HOUR( 11) },
{ "y", tZONE, HOUR( 12) },
{ "z", tZONE, HOUR( 0) },
{ NULL, 0, 0 }
};
static inline const char *
bypassSpaces(
const char *s)
{
while (TclIsSpaceProc(*s)) {
s++;
}
return s;
}
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
if (!infoPtr->messages) {
TclNewObj(infoPtr->messages);
}
Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1);
Tcl_AppendToObj(infoPtr->messages, s, -1);
Tcl_AppendToObj(infoPtr->messages, " (characters ", -1);
TclNewIntObj(t, location->first_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, "-", -1);
TclNewIntObj(t, location->last_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
int
ToSeconds(
int Hours,
int Minutes,
int Seconds,
MERIDIAN Meridian)
{
switch (Meridian) {
case MER24:
return (Hours * 60 + Minutes) * 60 + Seconds;
case MERam:
return (((Hours / 24) * 24 + (Hours % 12)) * 60 + Minutes) * 60 + Seconds;
case MERpm:
return (((Hours / 24) * 24 + (Hours % 12) + 12) * 60 + Minutes) * 60 + Seconds;
}
return -1; /* Should never be reached */
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
char *p;
char *q;
const TABLE *tp;
int i, abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
if (*buff == 'a' && (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0)) {
yylvalPtr->Meridian = MERam;
return tMERIDIAN;
}
if (*buff == 'p' && (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0)) {
yylvalPtr->Meridian = MERpm;
return tMERIDIAN;
}
/*
* See if we have an abbreviation for a month.
*/
|
| ︙ | ︙ | |||
2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 |
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| > | > > > | > > | | > > > | | > | > | > > > > > | | < > | > | > > > > | > > > | > < < | > > | < > | | | | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < | < < < < < | | | | | | | < | | < < < < < < | < < < | < | | < > | < < < < | | > > > > > > > > > > > > > > > > | > | | > | < | | < | | > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 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 |
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
const char *tokStart;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
if (isspace(UCHAR(*yyInput))) {
yyInput = bypassSpaces(yyInput);
/* ignore space at end of text and before some words */
c = *yyInput;
if (c != '\0' && !isalpha(UCHAR(c))) {
return SP;
}
}
tokStart = yyInput;
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Count the number of digits.
*/
p = (char *)yyInput;
while (isdigit(UCHAR(*++p))) {};
yyDigitCount = p - yyInput;
/*
* A number with 12 or 14 digits is considered an ISO 8601 date.
*/
if (yyDigitCount == 14 || yyDigitCount == 12) {
/* long form of ISO 8601 (without separator), either
* YYYYMMDDhhmmss or YYYYMMDDhhmm, so reduce to date
* (8 chars is isodate) */
p = (char *)yyInput+8;
if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
return tID; /* overflow*/
}
yyDigitCount = 8;
yyInput = p;
location->last_column = yyInput - info->dateStart - 1;
return tISOBASL;
}
/*
* Convert the string into a number
*/
if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
return tID; /* overflow*/
}
yyInput = p;
/*
* A number with 6 or more digits is considered an ISO 8601 base.
*/
location->last_column = yyInput - info->dateStart - 1;
if (yyDigitCount >= 6) {
if (yyDigitCount == 8) {
return tISOBAS8;
}
if (yyDigitCount == 6) {
return tISOBAS6;
}
}
/* ignore spaces after digits (optional) */
yyInput = bypassSpaces(yyInput);
return tUNUMBER;
}
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
int ret;
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
if (p < &buff[sizeof(buff) - 1]) {
*p++ = c;
}
}
*p = '\0';
yyInput--;
location->last_column = yyInput - info->dateStart - 1;
ret = LookupWord(yylvalPtr, buff);
/*
* lookahead:
* for spaces to consider word boundaries (for instance
* literal T in isodateTisotimeZ is not a TZ, but Z is UTC);
* for +/- digit, to differentiate between "GMT+1000 day" and "GMT +1000 day";
* bypass spaces after token (but ignore by TZ+OFFS), because should
* recognize next SP token, if TZ only.
*/
if (ret == tZONE || ret == tDAYZONE) {
c = *yyInput;
if (isdigit(UCHAR(c))) { /* literal not a TZ */
yyInput = tokStart;
return *yyInput++;
}
if ((c == '+' || c == '-') && isdigit(UCHAR(*(yyInput+1)))) {
if ( !isdigit(UCHAR(*(yyInput+2)))
|| !isdigit(UCHAR(*(yyInput+3)))) {
/* GMT+1, GMT-10, etc. */
return tZONEwO2;
}
if ( isdigit(UCHAR(*(yyInput+4)))
&& !isdigit(UCHAR(*(yyInput+5)))) {
/* GMT+1000, etc. */
return tZONEwO4;
}
}
}
yyInput = bypassSpaces(yyInput);
return ret;
}
if (c != '(') {
location->last_column = yyInput - info->dateStart;
return *yyInput++;
}
Count = 0;
do {
c = *yyInput++;
if (c == '\0') {
location->last_column = yyInput - info->dateStart - 1;
return c;
} else if (c == '(') {
Count++;
} else if (c == ')') {
Count--;
}
} while (Count > 0);
}
}
int
TclClockFreeScan(
Tcl_Interp *interp, /* Tcl interpreter */
DateInfo *info) /* Input and result parameters */
{
int status;
#if YYDEBUG
/* enable debugging if compiled with YYDEBUG */
yydebug = 1;
#endif
/*
* yyInput = stringToParse;
*
* ClockInitDateInfo(info) should be executed to pre-init info;
*/
yyDSTmode = DSTmaybe;
info->separatrix = "";
info->dateStart = yyInput;
/* ignore spaces at begin */
yyInput = bypassSpaces(yyInput);
/* parse */
status = yyparse(info);
if (status == 1) {
const char *msg = NULL;
if (info->errFlags & CLF_HAVEDATE) {
msg = "more than one date in string";
} else if (info->errFlags & CLF_TIME) {
msg = "more than one time of day in string";
} else if (info->errFlags & CLF_ZONE) {
msg = "more than one time zone in string";
} else if (info->errFlags & CLF_DAYOFWEEK) {
msg = "more than one weekday in string";
} else if (info->errFlags & CLF_ORDINALMONTH) {
msg = "more than one ordinal month in string";
}
if (msg) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
} else {
Tcl_SetObjResult(interp,
info->messages ? info->messages : Tcl_NewObj());
info->messages = NULL;
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL);
}
status = TCL_ERROR;
} else if (status == 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
status = TCL_ERROR;
} else if (status != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
"from date parser. Please "
"report this error as a "
"bug in Tcl.", -1));
Tcl_SetErrorCode(interp, "TCL", "BUG", (char *)NULL);
status = TCL_ERROR;
}
if (info->messages) {
Tcl_DecrRefCount(info->messages);
}
return status;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Added generic/tclDate.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* tclDate.h --
*
* This header file handles common usage of clock primitives
* between tclDate.c (yacc), tclClock.c and tclClockFmt.c.
*
* Copyright (c) 2014 Serg G. Brester (aka sebres)
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLCLOCK_H
#define _TCLCLOCK_H
/*
* Constants
*/
#define JULIAN_DAY_POSIX_EPOCH 2440588
#define GREGORIAN_CHANGE_DATE 2361222
#define SECONDS_PER_DAY 86400
#define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \
* SECONDS_PER_DAY)
#define FOUR_CENTURIES 146097 /* days */
#define JDAY_1_JAN_1_CE_JULIAN 1721424
#define JDAY_1_JAN_1_CE_GREGORIAN 1721426
#define ONE_CENTURY_GREGORIAN 36524 /* days */
#define FOUR_YEARS 1461 /* days */
#define ONE_YEAR 365 /* days */
#define RODDENBERRY 1946 /* Another epoch (Hi, Jeff!) */
enum DateInfoFlags {
CLF_OPTIONAL = 1 << 0, /* token is non mandatory */
CLF_POSIXSEC = 1 << 1,
CLF_LOCALSEC = 1 << 2,
CLF_JULIANDAY = 1 << 3,
CLF_TIME = 1 << 4,
CLF_ZONE = 1 << 5,
CLF_CENTURY = 1 << 6,
CLF_DAYOFMONTH = 1 << 7,
CLF_DAYOFYEAR = 1 << 8,
CLF_MONTH = 1 << 9,
CLF_YEAR = 1 << 10,
CLF_DAYOFWEEK = 1 << 11,
CLF_ISO8601YEAR = 1 << 12,
CLF_ISO8601WEEK = 1 << 13,
CLF_ISO8601CENTURY = 1 << 14,
CLF_SIGNED = 1 << 15,
/* Compounds */
CLF_HAVEDATE = (CLF_DAYOFMONTH | CLF_MONTH | CLF_YEAR),
CLF_DATE = (CLF_JULIANDAY | CLF_DAYOFMONTH | CLF_DAYOFYEAR
| CLF_MONTH | CLF_YEAR | CLF_ISO8601YEAR
| CLF_DAYOFWEEK | CLF_ISO8601WEEK),
/*
* Extra flags used outside of scan/format-tokens too (int, not a short).
*/
CLF_RELCONV = 1 << 17,
CLF_ORDINALMONTH = 1 << 18,
/* On demand (lazy) assemble flags */
CLF_ASSEMBLE_DATE = 1 << 28,/* assemble year, month, etc. using julianDay */
CLF_ASSEMBLE_JULIANDAY = 1 << 29,
/* assemble julianDay using year, month, etc. */
CLF_ASSEMBLE_SECONDS = 1 << 30
/* assemble localSeconds (and seconds at end) */
};
#define TCL_MIN_SECONDS -0x00F0000000000000LL
#define TCL_MAX_SECONDS 0x00F0000000000000LL
#define TCL_INV_SECONDS (TCL_MIN_SECONDS - 1)
/*
* Enumeration of the string literals used in [clock]
*/
typedef enum ClockLiteral {
LIT__NIL,
LIT__DEFAULT_FORMAT,
LIT_SYSTEM, LIT_CURRENT, LIT_C,
LIT_BCE, LIT_CE,
LIT_DAYOFMONTH, LIT_DAYOFWEEK, LIT_DAYOFYEAR,
LIT_ERA, LIT_GMT, LIT_GREGORIAN,
LIT_INTEGER_VALUE_TOO_LARGE,
LIT_ISO8601WEEK, LIT_ISO8601YEAR,
LIT_JULIANDAY, LIT_LOCALSECONDS,
LIT_MONTH,
LIT_SECONDS, LIT_TZNAME, LIT_TZOFFSET,
LIT_YEAR,
LIT_TZDATA,
LIT_GETSYSTEMTIMEZONE,
LIT_SETUPTIMEZONE,
LIT_MCGET,
LIT_GETSYSTEMLOCALE, LIT_GETCURRENTLOCALE,
LIT_LOCALIZE_FORMAT,
LIT__END
} ClockLiteral;
#define CLOCK_LITERAL_ARRAY(litarr) static const char *const litarr[] = { \
"", \
"%a %b %d %H:%M:%S %Z %Y", \
"system", "current", "C", \
"BCE", "CE", \
"dayOfMonth", "dayOfWeek", "dayOfYear", \
"era", ":GMT", "gregorian", \
"integer value too large to represent", \
"iso8601Week", "iso8601Year", \
"julianDay", "localSeconds", \
"month", \
"seconds", "tzName", "tzOffset", \
"year", \
"::tcl::clock::TZData", \
"::tcl::clock::GetSystemTimeZone", \
"::tcl::clock::SetupTimeZone", \
"::tcl::clock::mcget", \
"::tcl::clock::GetSystemLocale", "::tcl::clock::mclocale", \
"::tcl::clock::LocalizeFormat" \
}
/*
* Enumeration of the msgcat literals used in [clock]
*/
typedef enum ClockMsgCtLiteral {
MCLIT__NIL, /* placeholder */
MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, MCLIT_MONTHS_COMB,
MCLIT_DAYS_OF_WEEK_FULL, MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_COMB,
MCLIT_AM, MCLIT_PM,
MCLIT_LOCALE_ERAS,
MCLIT_BCE, MCLIT_CE,
MCLIT_BCE2, MCLIT_CE2,
MCLIT_BCE3, MCLIT_CE3,
MCLIT_LOCALE_NUMERALS,
MCLIT__END
} ClockMsgCtLiteral;
#define CLOCK_LOCALE_LITERAL_ARRAY(litarr, pref) static const char *const litarr[] = { \
pref "", \
pref "MONTHS_FULL", pref "MONTHS_ABBREV", pref "MONTHS_COMB", \
pref "DAYS_OF_WEEK_FULL", pref "DAYS_OF_WEEK_ABBREV", pref "DAYS_OF_WEEK_COMB", \
pref "AM", pref "PM", \
pref "LOCALE_ERAS", \
pref "BCE", pref "CE", \
pref "b.c.e.", pref "c.e.", \
pref "b.c.", pref "a.d.", \
pref "LOCALE_NUMERALS", \
}
/*
* Structure containing the fields used in [clock format] and [clock scan]
*/
enum TclDateFieldsFlags {
CLF_CTZ = (1 << 4)
};
typedef struct TclDateFields {
/* Cacheable fields: */
Tcl_WideInt seconds; /* Time expressed in seconds from the Posix
* epoch */
Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds
* from the Posix epoch */
int tzOffset; /* Time zone offset in seconds east of
* Greenwich */
Tcl_WideInt julianDay; /* Julian Day Number in local time zone */
int isBce; /* 1 if BCE */
int gregorian; /* Flag == 1 if the date is Gregorian */
int year; /* Year of the era */
int dayOfYear; /* Day of the year (1 January == 1) */
int month; /* Month number */
int dayOfMonth; /* Day of the month */
int iso8601Year; /* ISO8601 week-based year */
int iso8601Week; /* ISO8601 week number */
int dayOfWeek; /* Day of the week */
int hour; /* Hours of day (in-between time only calculation) */
int minutes; /* Minutes of hour (in-between time only calculation) */
Tcl_WideInt secondOfMin; /* Seconds of minute (in-between time only calculation) */
Tcl_WideInt secondOfDay; /* Seconds of day (in-between time only calculation) */
int flags; /* 0 or CLF_CTZ */
/* Non cacheable fields: */
Tcl_Obj *tzName; /* Name (or corresponding DST-abbreviation) of the
* time zone, if set the refCount is incremented */
} TclDateFields;
#define ClockCacheableDateFieldsSize \
offsetof(TclDateFields, tzName)
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* Structure contains return parsed fields.
*/
typedef struct DateInfo {
const char *dateStart;
const char *dateInput;
const char *dateEnd;
TclDateFields date;
int flags; /* Signals parts of date/time get found */
int errFlags; /* Signals error (part of date/time found twice) */
MERIDIAN dateMeridian;
int dateTimezone;
int dateDSTmode;
Tcl_WideInt dateRelMonth;
Tcl_WideInt dateRelDay;
Tcl_WideInt dateRelSeconds;
int dateMonthOrdinalIncr;
int dateMonthOrdinal;
int dateDayOrdinal;
Tcl_WideInt *dateRelPointer;
int dateSpaceCount;
int dateDigitCount;
int dateCentury;
Tcl_Obj *messages; /* Error messages */
const char* separatrix; /* String separating messages */
} DateInfo;
#define yydate (info->date) /* Date fields used for converting */
#define yyDay (info->date.dayOfMonth)
#define yyMonth (info->date.month)
#define yyYear (info->date.year)
#define yyHour (info->date.hour)
#define yyMinutes (info->date.minutes)
#define yySeconds (info->date.secondOfMin)
#define yySecondOfDay (info->date.secondOfDay)
#define yyDSTmode (info->dateDSTmode)
#define yyDayOrdinal (info->dateDayOrdinal)
#define yyDayOfWeek (info->date.dayOfWeek)
#define yyMonthOrdinalIncr (info->dateMonthOrdinalIncr)
#define yyMonthOrdinal (info->dateMonthOrdinal)
#define yyTimezone (info->dateTimezone)
#define yyMeridian (info->dateMeridian)
#define yyRelMonth (info->dateRelMonth)
#define yyRelDay (info->dateRelDay)
#define yyRelSeconds (info->dateRelSeconds)
#define yyRelPointer (info->dateRelPointer)
#define yyInput (info->dateInput)
#define yyDigitCount (info->dateDigitCount)
#define yySpaceCount (info->dateSpaceCount)
static inline void
ClockInitDateInfo(
DateInfo *info)
{
memset(info, 0, sizeof(DateInfo));
}
/*
* Structure containing the command arguments supplied to [clock format] and [clock scan]
*/
enum ClockFmtScnCmdArgsFlags {
CLF_VALIDATE_S1 = (1 << 0),
CLF_VALIDATE_S2 = (1 << 1),
CLF_VALIDATE = (CLF_VALIDATE_S1|CLF_VALIDATE_S2),
CLF_EXTENDED = (1 << 4),
CLF_STRICT = (1 << 8),
CLF_LOCALE_USED = (1 << 15)
};
typedef struct ClockClientData ClockClientData;
typedef struct ClockFmtScnCmdArgs {
ClockClientData *dataPtr; /* Pointer to literal pool, etc. */
Tcl_Interp *interp; /* Tcl interpreter */
Tcl_Obj *formatObj; /* Format */
Tcl_Obj *localeObj; /* Name of the locale where the time will be expressed. */
Tcl_Obj *timezoneObj; /* Default time zone in which the time will be expressed */
Tcl_Obj *baseObj; /* Base (scan and add) or clockValue (format) */
int flags; /* Flags control scanning */
Tcl_Obj *mcDictObj; /* Current dictionary of tcl::clock package for given localeObj*/
} ClockFmtScnCmdArgs;
/* Last-period cache for fast UTC to local and backwards conversion */
typedef struct ClockLastTZOffs {
/* keys */
Tcl_Obj *timezoneObj;
int changeover;
Tcl_WideInt localSeconds;
Tcl_WideInt rangesVal[2]; /* Bounds for cached time zone offset */
/* values */
int tzOffset;
Tcl_Obj *tzName; /* Name (abbreviation) of this area in TZ */
} ClockLastTZOffs;
/*
* Structure containing the client data for [clock]
*/
typedef struct ClockClientData {
size_t refCount; /* Number of live references. */
Tcl_Obj **literals; /* Pool of object literals (common, locale independent). */
Tcl_Obj **mcLiterals; /* Msgcat object literals with mc-keys for search with locale. */
Tcl_Obj **mcLitIdxs; /* Msgcat object indices prefixed with _IDX_,
* used for quick dictionary search */
Tcl_Obj *mcDicts; /* Msgcat collection, contains weak pointers to locale
* catalogs, and owns it references (onetime referenced) */
/* Cache for current clock parameters, imparted via "configure" */
size_t lastTZEpoch;
int currentYearCentury;
int yearOfCenturySwitch;
int validMinYear;
int validMaxYear;
double maxJDN;
Tcl_Obj *systemTimeZone;
Tcl_Obj *systemSetupTZData;
Tcl_Obj *gmtSetupTimeZoneUnnorm;
Tcl_Obj *gmtSetupTimeZone;
Tcl_Obj *gmtSetupTZData;
Tcl_Obj *gmtTZName;
Tcl_Obj *lastSetupTimeZoneUnnorm;
Tcl_Obj *lastSetupTimeZone;
Tcl_Obj *lastSetupTZData;
Tcl_Obj *prevSetupTimeZoneUnnorm;
Tcl_Obj *prevSetupTimeZone;
Tcl_Obj *prevSetupTZData;
Tcl_Obj *defaultLocale;
Tcl_Obj *defaultLocaleDict;
Tcl_Obj *currentLocale;
Tcl_Obj *currentLocaleDict;
Tcl_Obj *lastUsedLocaleUnnorm;
Tcl_Obj *lastUsedLocale;
Tcl_Obj *lastUsedLocaleDict;
Tcl_Obj *prevUsedLocaleUnnorm;
Tcl_Obj *prevUsedLocale;
Tcl_Obj *prevUsedLocaleDict;
/* Cache for last base (last-second fast convert if base/tz not changed) */
struct {
Tcl_Obj *timezoneObj;
TclDateFields date;
} lastBase;
/* Last-period cache for fast UTC to Local and backwards conversion */
ClockLastTZOffs lastTZOffsCache[2];
int defFlags; /* Default flags (from configure), ATM
* only CLF_VALIDATE supported */
} ClockClientData;
#define ClockDefaultYearCentury 2000
#define ClockDefaultCenturySwitch 38
/*
* Clock scan and format facilities.
*/
#ifndef TCL_MEM_DEBUG
# define CLOCK_FMT_SCN_STORAGE_GC_SIZE 32
#else
# define CLOCK_FMT_SCN_STORAGE_GC_SIZE 0
#endif
#define CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE 2
typedef struct ClockScanToken ClockScanToken;
typedef int ClockScanTokenProc(
ClockFmtScnCmdArgs *opts,
DateInfo *info,
ClockScanToken *tok);
typedef enum _CLCKTOK_TYPE {
CTOKT_INT = 1, CTOKT_WIDE, CTOKT_PARSER, CTOKT_SPACE, CTOKT_WORD, CTOKT_CHAR,
CFMTT_PROC
} CLCKTOK_TYPE;
typedef struct ClockScanTokenMap {
unsigned short type;
unsigned short flags;
unsigned short clearFlags;
unsigned short minSize;
unsigned short maxSize;
unsigned short offs;
ClockScanTokenProc *parser;
const void *data;
} ClockScanTokenMap;
struct ClockScanToken {
const ClockScanTokenMap *map;
struct {
const char *start;
const char *end;
} tokWord;
unsigned short endDistance;
unsigned short lookAhMin;
unsigned short lookAhMax;
unsigned short lookAhTok;
};
#define MIN_FMT_RESULT_BLOCK_ALLOC 80
#define MIN_FMT_RESULT_BLOCK_DELTA 0
/* Maximal permitted threshold (buffer size > result size) in percent,
* to directly return the buffer without reallocate */
#define MAX_FMT_RESULT_THRESHOLD 2
typedef struct DateFormat {
char *resMem;
char *resEnd;
char *output;
TclDateFields date;
Tcl_Obj *localeEra;
} DateFormat;
enum ClockFormatTokenMapFlags {
CLFMT_INCR = (1 << 3),
CLFMT_DECR = (1 << 4),
CLFMT_CALC = (1 << 5),
CLFMT_LOCALE_INDX = (1 << 8)
};
typedef struct ClockFormatToken ClockFormatToken;
typedef int ClockFormatTokenProc(
ClockFmtScnCmdArgs *opts,
DateFormat *dateFmt,
ClockFormatToken *tok,
int *val);
typedef struct ClockFormatTokenMap {
unsigned short type;
const char *tostr;
unsigned short width;
unsigned short flags;
unsigned short divider;
unsigned short divmod;
unsigned short offs;
ClockFormatTokenProc *fmtproc;
void *data;
} ClockFormatTokenMap;
struct ClockFormatToken {
const ClockFormatTokenMap *map;
struct {
const char *start;
const char *end;
} tokWord;
};
typedef struct ClockFmtScnStorage ClockFmtScnStorage;
struct ClockFmtScnStorage {
int objRefCount; /* Reference count shared across threads */
ClockScanToken *scnTok;
unsigned scnTokC;
unsigned scnSpaceCount; /* Count of mandatory spaces used in format */
ClockFormatToken *fmtTok;
unsigned fmtTokC;
#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
ClockFmtScnStorage *nextPtr;
ClockFmtScnStorage *prevPtr;
#endif
size_t fmtMinAlloc;
#if 0
Tcl_HashEntry hashEntry /* ClockFmtScnStorage is a derivate of Tcl_HashEntry,
* stored by offset +sizeof(self) */
#endif
};
/*
* Clock macros.
*/
/*
* Extracts Julian day and seconds of the day from posix seconds (tm).
*/
#define ClockExtractJDAndSODFromSeconds(jd, sod, tm) \
do { \
jd = (tm + JULIAN_SEC_POSIX_EPOCH); \
if (jd >= SECONDS_PER_DAY || jd <= -SECONDS_PER_DAY) { \
jd /= SECONDS_PER_DAY; \
sod = (int)(tm % SECONDS_PER_DAY); \
} else { \
sod = (int)jd, jd = 0; \
} \
if (sod < 0) { \
sod += SECONDS_PER_DAY; \
/* JD is affected, if switched into negative (avoid 24 hours difference) */ \
if (jd <= 0) { \
jd--; \
} \
} \
} while(0)
/*
* Prototypes of module functions.
*/
MODULE_SCOPE int ToSeconds(int Hours, int Minutes,
int Seconds, MERIDIAN Meridian);
MODULE_SCOPE int IsGregorianLeapYear(TclDateFields *);
MODULE_SCOPE void GetJulianDayFromEraYearWeekDay(
TclDateFields *fields, int changeover);
MODULE_SCOPE void GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, int changeover);
MODULE_SCOPE void GetJulianDayFromEraYearDay(
TclDateFields *fields, int changeover);
MODULE_SCOPE int ConvertUTCToLocal(ClockClientData *dataPtr, Tcl_Interp *,
TclDateFields *, Tcl_Obj *timezoneObj, int);
MODULE_SCOPE Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
Tcl_Size, Tcl_Obj *const *, Tcl_WideInt *rangesVal);
MODULE_SCOPE int TclClockFreeScan(Tcl_Interp *interp, DateInfo *info);
/* tclClock.c module declarations */
MODULE_SCOPE Tcl_Obj * ClockSetupTimeZone(ClockClientData *dataPtr,
Tcl_Interp *interp, Tcl_Obj *timezoneObj);
MODULE_SCOPE Tcl_Obj * ClockMCDict(ClockFmtScnCmdArgs *opts);
MODULE_SCOPE Tcl_Obj * ClockMCGet(ClockFmtScnCmdArgs *opts, int mcKey);
MODULE_SCOPE Tcl_Obj * ClockMCGetIdx(ClockFmtScnCmdArgs *opts, int mcKey);
MODULE_SCOPE int ClockMCSetIdx(ClockFmtScnCmdArgs *opts, int mcKey,
Tcl_Obj *valObj);
/* tclClockFmt.c module declarations */
MODULE_SCOPE char * TclItoAw(char *buf, int val, char padchar, unsigned short width);
MODULE_SCOPE int TclAtoWIe(Tcl_WideInt *out, const char *p, const char *e, int sign);
MODULE_SCOPE Tcl_Obj* ClockFrmObjGetLocFmtKey(Tcl_Interp *interp,
Tcl_Obj *objPtr);
MODULE_SCOPE ClockFmtScnStorage *Tcl_GetClockFrmScnFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
MODULE_SCOPE Tcl_Obj * ClockLocalizeFormat(ClockFmtScnCmdArgs *opts);
MODULE_SCOPE int ClockScan(DateInfo *info, Tcl_Obj *strObj,
ClockFmtScnCmdArgs *opts);
MODULE_SCOPE int ClockFormat(DateFormat *dateFmt,
ClockFmtScnCmdArgs *opts);
MODULE_SCOPE void ClockFrmScnClearCaches(void);
MODULE_SCOPE void ClockFrmScnFinalize();
#endif /* _TCLCLOCK_H */
|
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
423 424 425 426 427 428 429 | /* Slot 144 is reserved */ /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); /* Slot 147 is reserved */ | | < < < < < | | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 | /* Slot 144 is reserved */ /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); /* Slot 147 is reserved */ /* Slot 148 is reserved */ /* 149 */ EXTERN int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 150 */ EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 151 */ EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); |
| ︙ | ︙ | |||
757 758 759 760 761 762 763 | /* 282 */ EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 283 */ EXTERN Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan); /* 284 */ EXTERN void Tcl_SetMainLoop(Tcl_MainLoopProc *proc); | | > > > > > | 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 | /* 282 */ EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 283 */ EXTERN Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan); /* 284 */ EXTERN void Tcl_SetMainLoop(Tcl_MainLoopProc *proc); /* 285 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 286 */ EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 287 */ EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr); /* 288 */ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, |
| ︙ | ︙ | |||
1761 1762 1763 1764 1765 1766 1767 | /* 654 */ EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length); /* 655 */ EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ | | > | 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 | /* 654 */ EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length); /* 655 */ EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ EXTERN int Tcl_FSTildeExpand(Tcl_Interp *interp, const char *path, Tcl_DString *dsPtr); /* 658 */ EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */ |
| ︙ | ︙ | |||
1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 |
EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr);
/* 686 */
EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n);
/* 687 */
EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2,
size_t n);
/* 688 */
EXTERN void TclUnusedStubEntry(void);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
| > > > > > | 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 |
EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr);
/* 686 */
EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n);
/* 687 */
EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2,
size_t n);
/* 688 */
EXTERN Tcl_Obj * Tcl_NewWideUIntObj(Tcl_WideUInt wideValue);
/* 689 */
EXTERN void Tcl_SetWideUIntObj(Tcl_Obj *objPtr,
Tcl_WideUInt uwideValue);
/* 690 */
EXTERN void TclUnusedStubEntry(void);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
|
| ︙ | ︙ | |||
2024 2025 2026 2027 2028 2029 2030 |
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
void (*reserved144)(void);
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*reserved147)(void);
| | | | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 |
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
void (*reserved144)(void);
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*reserved147)(void);
void (*reserved148)(void);
int (*tclGetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 149 */
void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */
Tcl_Size (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, void **handlePtr); /* 153 */
void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
void (*reserved278)(void);
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */
| | | 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 |
void (*reserved278)(void);
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 285 */
void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */
void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */
void (*reserved290)(void);
int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); /* 291 */
int (*tcl_EvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 292 */
|
| ︙ | ︙ | |||
2533 2534 2535 2536 2537 2538 2539 |
unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 650 */
char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 651 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 652 */
int (*tcl_GetSizeIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *sizePtr); /* 653 */
int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */
const char * (*tcl_UtfNext) (const char *src); /* 655 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
| | | 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 |
unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 650 */
char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 651 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 652 */
int (*tcl_GetSizeIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *sizePtr); /* 653 */
int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */
const char * (*tcl_UtfNext) (const char *src); /* 655 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
int (*tcl_FSTildeExpand) (Tcl_Interp *interp, const char *path, Tcl_DString *dsPtr); /* 657 */
int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */
int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */
int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 661 */
int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *lengthPtr); /* 662 */
int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr); /* 663 */
int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, const char ***argvPtr); /* 664 */
|
| ︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 |
int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, void **clientDataPtr, int *typePtr); /* 681 */
int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */
int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */
| > > | | 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 |
int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, void **clientDataPtr, int *typePtr); /* 681 */
int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */
int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */
Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */
void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */
void (*tclUnusedStubEntry) (void); /* 690 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
2857 2858 2859 2860 2861 2862 2863 | (tclStubsPtr->tcl_Finalize) /* 143 */ /* Slot 144 is reserved */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ /* Slot 147 is reserved */ | < | | | | 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 | (tclStubsPtr->tcl_Finalize) /* 143 */ /* Slot 144 is reserved */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ /* Slot 147 is reserved */ /* Slot 148 is reserved */ #define TclGetAliasObj \ (tclStubsPtr->tclGetAliasObj) /* 149 */ #define Tcl_GetAssocData \ (tclStubsPtr->tcl_GetAssocData) /* 150 */ #define Tcl_GetChannel \ (tclStubsPtr->tcl_GetChannel) /* 151 */ #define Tcl_GetChannelBufferSize \ (tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */ #define Tcl_GetChannelHandle \ |
| ︙ | ︙ | |||
3105 3106 3107 3108 3109 3110 3111 | (tclStubsPtr->tcl_StackChannel) /* 281 */ #define Tcl_UnstackChannel \ (tclStubsPtr->tcl_UnstackChannel) /* 282 */ #define Tcl_GetStackedChannel \ (tclStubsPtr->tcl_GetStackedChannel) /* 283 */ #define Tcl_SetMainLoop \ (tclStubsPtr->tcl_SetMainLoop) /* 284 */ | > | | 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 | (tclStubsPtr->tcl_StackChannel) /* 281 */ #define Tcl_UnstackChannel \ (tclStubsPtr->tcl_UnstackChannel) /* 282 */ #define Tcl_GetStackedChannel \ (tclStubsPtr->tcl_GetStackedChannel) /* 283 */ #define Tcl_SetMainLoop \ (tclStubsPtr->tcl_SetMainLoop) /* 284 */ #define Tcl_GetAliasObj \ (tclStubsPtr->tcl_GetAliasObj) /* 285 */ #define Tcl_AppendObjToObj \ (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ #define Tcl_CreateEncoding \ (tclStubsPtr->tcl_CreateEncoding) /* 287 */ #define Tcl_CreateThreadExitHandler \ (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ #define Tcl_DeleteThreadExitHandler \ |
| ︙ | ︙ | |||
3831 3832 3833 3834 3835 3836 3837 | (tclStubsPtr->tcl_GetSizeIntFromObj) /* 653 */ #define Tcl_UtfCharComplete \ (tclStubsPtr->tcl_UtfCharComplete) /* 654 */ #define Tcl_UtfNext \ (tclStubsPtr->tcl_UtfNext) /* 655 */ #define Tcl_UtfPrev \ (tclStubsPtr->tcl_UtfPrev) /* 656 */ | | | | 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 | (tclStubsPtr->tcl_GetSizeIntFromObj) /* 653 */ #define Tcl_UtfCharComplete \ (tclStubsPtr->tcl_UtfCharComplete) /* 654 */ #define Tcl_UtfNext \ (tclStubsPtr->tcl_UtfNext) /* 655 */ #define Tcl_UtfPrev \ (tclStubsPtr->tcl_UtfPrev) /* 656 */ #define Tcl_FSTildeExpand \ (tclStubsPtr->tcl_FSTildeExpand) /* 657 */ #define Tcl_ExternalToUtfDStringEx \ (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 658 */ #define Tcl_UtfToExternalDStringEx \ (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ #define Tcl_ListObjGetElements \ |
| ︙ | ︙ | |||
3893 3894 3895 3896 3897 3898 3899 3900 | (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */ #define Tcl_DStringToObj \ (tclStubsPtr->tcl_DStringToObj) /* 685 */ #define Tcl_UtfNcmp \ (tclStubsPtr->tcl_UtfNcmp) /* 686 */ #define Tcl_UtfNcasecmp \ (tclStubsPtr->tcl_UtfNcasecmp) /* 687 */ #define TclUnusedStubEntry \ | > > > > | | 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 | (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */ #define Tcl_DStringToObj \ (tclStubsPtr->tcl_DStringToObj) /* 685 */ #define Tcl_UtfNcmp \ (tclStubsPtr->tcl_UtfNcmp) /* 686 */ #define Tcl_UtfNcasecmp \ (tclStubsPtr->tcl_UtfNcasecmp) /* 687 */ #define Tcl_NewWideUIntObj \ (tclStubsPtr->tcl_NewWideUIntObj) /* 688 */ #define Tcl_SetWideUIntObj \ (tclStubsPtr->tcl_SetWideUIntObj) /* 689 */ #define TclUnusedStubEntry \ (tclStubsPtr->tclUnusedStubEntry) /* 690 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TclUnusedStubEntry |
| ︙ | ︙ | |||
3956 3957 3958 3959 3960 3961 3962 |
#define Tcl_SetResult(interp, result, freeProc) \
do { \
const char *__result = result; \
Tcl_FreeProc *__freeProc = freeProc; \
Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \
if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
if (__freeProc == TCL_DYNAMIC) { \
| | | | 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 |
#define Tcl_SetResult(interp, result, freeProc) \
do { \
const char *__result = result; \
Tcl_FreeProc *__freeProc = freeProc; \
Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \
if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
if (__freeProc == TCL_DYNAMIC) { \
Tcl_Free((void *)__result); \
} else { \
(*__freeProc)((void *)__result); \
} \
} \
} while(0)
#if defined(USE_TCL_STUBS)
# if defined(_WIN32) && defined(_WIN64) && TCL_MAJOR_VERSION < 9
# undef Tcl_GetTime
|
| ︙ | ︙ | |||
4019 4020 4021 4022 4023 4024 4025 | #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 | > > > | | > | | > | | > | | > | | > | 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 |
#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(TCLBOOLWARNING)
#if !defined(__cplusplus) && !defined(BUILD_tcl) && !defined(BUILD_tk) && defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 201112L)
# define TCLBOOLWARNING(boolPtr) (void)(sizeof(struct {_Static_assert(sizeof(*(boolPtr)) <= sizeof(int), "sizeof(boolPtr) too large");int dummy;})),
#elif defined(__GNUC__) && !defined(__STRICT_ANSI__)
/* 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
#endif /* !TCLBOOLWARNING */
#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) \
((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
(TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
(TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
#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) \
((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
(TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
(TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
#endif
#ifdef TCL_MEM_DEBUG
# undef Tcl_Alloc
# define Tcl_Alloc(x) \
(Tcl_DbCkalloc((x), __FILE__, __LINE__))
# undef Tcl_Free
|
| ︙ | ︙ | |||
4156 4157 4158 4159 4160 4161 4162 | #undef TclUtfPrev #ifndef TCL_NO_DEPRECATED # define Tcl_CreateSlave Tcl_CreateChild # define Tcl_GetSlave Tcl_GetChild # define Tcl_GetMaster Tcl_GetParent #endif | < | | | | | | | | | | | | | 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 |
#undef TclUtfPrev
#ifndef TCL_NO_DEPRECATED
# define Tcl_CreateSlave Tcl_CreateChild
# define Tcl_GetSlave Tcl_GetChild
# define Tcl_GetMaster Tcl_GetParent
#endif
/* Protect those 11 functions, make them useless through the stub table */
#undef TclGetStringFromObj
#undef TclGetBytesFromObj
#undef TclGetUnicodeFromObj
#undef TclListObjGetElements
#undef TclListObjLength
#undef TclDictObjSize
#undef TclSplitList
#undef TclSplitPath
#undef TclFSSplitPath
#undef TclParseArgsObjv
#undef TclGetAliasObj
#if TCL_MAJOR_VERSION < 9
/* TIP #627 for 8.7 */
# undef Tcl_CreateObjCommand2
# define Tcl_CreateObjCommand2 Tcl_CreateObjCommand
# undef Tcl_CreateObjTrace2
# define Tcl_CreateObjTrace2 Tcl_CreateObjTrace
|
| ︙ | ︙ | |||
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 | 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) ? \ | > > > > | | | > > > | 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 | 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)) # undef Tcl_GetAliasObj # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \ tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) #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 # undef Tcl_GetAliasObj # 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))) # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ TclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ (Tcl_GetAliasObj)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) # 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))) |
| ︙ | ︙ | |||
4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 | 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 */ | > > > | 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 | 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))) # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ tclStubsPtr->tcl_GetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) # 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/tclDictObj.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | Tcl_Obj *keyPtr); static Tcl_NRPostProc FinalizeDictUpdate; static Tcl_NRPostProc FinalizeDictWith; static Tcl_ObjCmdProc DictForNRCmd; static Tcl_ObjCmdProc DictMapNRCmd; static Tcl_NRPostProc DictForLoopCallback; static Tcl_NRPostProc DictMapLoopCallback; | < < | | 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 |
Tcl_Obj *keyPtr);
static Tcl_NRPostProc FinalizeDictUpdate;
static Tcl_NRPostProc FinalizeDictWith;
static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0},
{"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd,
NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
{"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
{"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
{"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
{"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
{"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 },
{"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 },
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
* dictionary. Used for doing traversal of the
* entries in the order that they are
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
| | | < < < < < < < < < < < | | | | | | | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 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 |
* dictionary. Used for doing traversal of the
* entries in the order that they are
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
size_t epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
} Dict;
/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
const Tcl_ObjType tclDictType = {
"dict",
FreeDictInternalRep, /* freeIntRepProc */
DupDictInternalRep, /* dupIntRepProc */
UpdateStringOfDict, /* updateStringProc */
SetDictFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define DictSetInternalRep(objPtr, dictRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (dictRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \
} while (0)
#define DictGetInternalRep(objPtr, dictRepPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &tclDictType); \
(dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The type of the specially adapted version of the Tcl_Obj*-containing hash
* table defined in the tclObj.c code. This version differs in that it
* allocates a bit more space in each hash entry in order to hold the pointers
* used to keep the hash entries in a linked list.
*
* Note that this type of hash table is *only* suitable for direct use in
* *this* file. Everything else should use the dict iterator API.
*/
static const Tcl_HashKeyType chainHashType = {
TCL_HASH_KEY_TYPE_VERSION,
TCL_HASH_KEY_DIRECT_COMPARE, /* allows compare keys by pointers */
TclHashObjKey,
TclCompareObjKeys,
AllocChainEntry,
TclFreeObjEntry
};
/*
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 | /* * Assume that cPtr is never NULL since we know the number of array * elements already. */ flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); | | | | | | 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 |
/*
* Assume that cPtr is never NULL since we know the number of array
* elements already.
*/
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
}
bytesNeeded += numElems;
/*
* Pass 2: copy into string rep buffer.
*/
dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
flagPtr[i+1] |= TCL_DONT_QUOTE_HASH;
valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
/* Last space overwrote the terminating NUL; cal T_ISR again to restore */
(void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 |
*/
if (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
| | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 |
*/
if (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
TclListObjGetElements(NULL, objPtr, &objc, &objv);
if (objc & 1) {
goto missingValue;
}
for (i=0 ; i<objc ; i+=2) {
/* Store key and value in the hash table we're building. */
|
| ︙ | ︙ | |||
644 645 646 647 648 649 650 |
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
}
} else {
Tcl_Size length;
| | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
}
} else {
Tcl_Size length;
const char *nextElem = TclGetStringFromObj(objPtr, &length);
const char *limit = (nextElem + length);
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
Tcl_Size elemSize;
int literal;
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
DictSetInternalRep(objPtr, dict);
return TCL_OK;
missingValue:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value to go with key", -1));
| | | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
DictSetInternalRep(objPtr, dict);
return TCL_OK;
missingValue:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (char *)NULL);
}
errorInFindDictElement:
DeleteChainTable(dict);
Tcl_Free(dict);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
}
if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(keyv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
| | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
}
if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(keyv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(keyv[i]), (char *)NULL);
}
return NULL;
}
/*
* The next line should always set isNew to 1.
*/
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 | * 'tclDicttype'. * * *---------------------------------------------------------------------- */ Tcl_Size | | > | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 |
* 'tclDicttype'.
*
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclDictGetSize(
Tcl_Obj *dictPtr)
{
Dict *dict;
DictGetInternalRep(dictPtr, dict);
return dict->table.numEntries;
}
/*
|
| ︙ | ︙ | |||
1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 |
Tcl_DbNewDictObj(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDictObj();
}
#endif
/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
/*
*----------------------------------------------------------------------
*
* DictCreateCmd --
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
Tcl_DbNewDictObj(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDictObj();
}
#endif
/***** START OF FUNCTIONS ACTING AS HELPERS *****/
/*
*----------------------------------------------------------------------
*
* TclDictGet --
*
* Given a key, get its value from the dictionary (or NULL if key is not
* found in dictionary.)
*
* Results:
* A standard Tcl result. The variable pointed to by valuePtrPtr is
* updated with the value for the key. Note that it is not an error for
* the key to have no mapping in the dictionary.
*
* Side effects:
* The object pointed to by dictPtr is converted to a dictionary if it is
* not already one.
*
*----------------------------------------------------------------------
*/
int
TclDictGet(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
const char *key, /* The key in a C string. */
Tcl_Obj **valuePtrPtr) /* Where to write the value. */
{
Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1);
int code;
Tcl_IncrRefCount(keyPtr);
code = Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr);
Tcl_DecrRefCount(keyPtr);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclDictPut --
*
* Add a key,value pair to a dictionary, or update the value for a key if
* that key already has a mapping in the dictionary.
*
* If valuePtr is a zero-count object and is not written into the
* dictionary because of an error, it is freed by this routine. The caller
* does NOT need to do reference count management.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The object pointed to by dictPtr is converted to a dictionary if it is
* not already one, and any string representation that it has is
* invalidated.
*
*----------------------------------------------------------------------
*/
int
TclDictPut(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
const char *key, /* The key in a C string. */
Tcl_Obj *valuePtr) /* The value to write in. */
{
Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1);
int code;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
code = Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr);
Tcl_DecrRefCount(keyPtr);
Tcl_DecrRefCount(valuePtr);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclDictPutString --
*
* Add a key,value pair to a dictionary, or update the value for a key if
* that key already has a mapping in the dictionary.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The object pointed to by dictPtr is converted to a dictionary if it is
* not already one, and any string representation that it has is
* invalidated.
*
*----------------------------------------------------------------------
*/
int
TclDictPutString(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
const char *key, /* The key in a C string. */
const char *value) /* The value in a C string. */
{
Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1);
Tcl_Obj *valuePtr = Tcl_NewStringObj(value, -1);
int code;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
code = Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr);
Tcl_DecrRefCount(keyPtr);
Tcl_DecrRefCount(valuePtr);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclDictRemove --
*
* Remove the key,value pair with the given key from the dictionary; the
* key does not need to be present in the dictionary.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The object pointed to by dictPtr is converted to a dictionary if it is
* not already one, and any string representation that it has is
* invalidated.
*
*----------------------------------------------------------------------
*/
int
TclDictRemove(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
const char *key) /* The key in a C string. */
{
Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1);
int code;
Tcl_IncrRefCount(keyPtr);
code = Tcl_DictObjRemove(interp, dictPtr, keyPtr);
Tcl_DecrRefCount(keyPtr);
return code;
}
/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
/*
*----------------------------------------------------------------------
*
* DictCreateCmd --
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
return result;
}
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(objv[objc-1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
| | | 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 |
return result;
}
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(objv[objc-1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(objv[objc-1]), (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 |
DictSizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int result;
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2265 2266 |
DictSizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int result;
Tcl_Size size;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclDictObjSmartRef --
*
* This function returns new tcl-object with the smart reference to
* dictionary object.
*
* Object returned with this function is a smart reference (pointer),
* so new object of type tclDictType, that directly references given
* dictionary object (with internally increased refCount).
*
* The usage of such pointer objects allows to hold more as one
* reference to the same real dictionary object, allows to make a pointer
* to part of another dictionary, allows to change the dictionary without
* regarding of the "shared" state of the dictionary object.
*
* Prevents "called with shared object" exception if object is multiple
* referenced.
*
* Results:
* The newly create object (contains smart reference) is returned.
* The returned object has a ref count of 0.
*
* Side effects:
* Increases ref count of the referenced dictionary.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclDictObjSmartRef(
Tcl_Interp *interp,
Tcl_Obj *dictPtr)
{
Tcl_Obj *result;
Dict *dict;
if (!TclHasInternalRep(dictPtr, &tclDictType)
&& SetDictFromAny(interp, dictPtr) != TCL_OK) {
return NULL;
}
DictGetInternalRep(dictPtr, dict);
result = Tcl_NewObj();
DictSetInternalRep(result, dict);
dict->refCount++;
result->internalRep.twoPtrValue.ptr2 = NULL;
result->typePtr = &tclDictType;
return result;
}
/*
*----------------------------------------------------------------------
*
* DictExistsCmd --
|
| ︙ | ︙ | |||
2505 2506 2507 2508 2509 2510 2511 |
return TCL_ERROR;
}
/*
* Parse arguments.
*/
| | | | | 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 |
return TCL_ERROR;
}
/*
* Parse arguments.
*/
if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", (char *)NULL);
return TCL_ERROR;
}
searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
TclStackFree(interp, searchPtr);
return TCL_ERROR;
}
if (done) {
TclStackFree(interp, searchPtr);
return TCL_OK;
}
TclListObjGetElements(NULL, objv[1], &varc, &varv);
keyVarObj = varv[0];
valueVarObj = varv[1];
scriptObj = objv[3];
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish. Note that the dictionary internal rep is locked
|
| ︙ | ︙ | |||
2700 2701 2702 2703 2704 2705 2706 |
return TCL_ERROR;
}
/*
* Parse arguments.
*/
| | | | | 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 |
return TCL_ERROR;
}
/*
* Parse arguments.
*/
if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", (char *)NULL);
return TCL_ERROR;
}
storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage));
if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
&valueObj, &done) != TCL_OK) {
TclStackFree(interp, storagePtr);
return TCL_ERROR;
}
if (done) {
/*
* Note that this exit leaves an empty value in the result (due to
* command calling conventions) but that is OK since an empty value is
* an empty dictionary.
*/
TclStackFree(interp, storagePtr);
return TCL_OK;
}
TclNewObj(storagePtr->accumulatorObj);
TclListObjGetElements(NULL, objv[1], &varc, &varv);
storagePtr->keyVarObj = varv[0];
storagePtr->valueVarObj = varv[1];
storagePtr->scriptObj = objv[3];
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish. Note that the dictionary internal rep is locked
|
| ︙ | ︙ | |||
3140 3141 3142 3143 3144 3145 3146 | /* * Create a dictionary whose key,value pairs all satisfy a script * (i.e. get a true boolean result from its evaluation). Massive * copying from the "dict for" implementation has occurred! */ | | | | 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 |
/*
* Create a dictionary whose key,value pairs all satisfy a script
* (i.e. get a true boolean result from its evaluation). Massive
* copying from the "dict for" implementation has occurred!
*/
if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", (char *)NULL);
return TCL_ERROR;
}
keyVarObj = varv[0];
valueVarObj = varv[1];
scriptObj = objv[4];
/*
|
| ︙ | ︙ | |||
3402 3403 3404 3405 3406 3407 3408 |
}
/*
* Write back the values from the variables, treating failure to read as
* an instruction to remove the key.
*/
| | | 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 |
}
/*
* Write back the values from the variables, treating failure to read as
* an instruction to remove the key.
*/
TclListObjGetElements(NULL, argsObj, &objc, &objv);
for (i=0 ; i<objc ; i+=2) {
objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
if (objPtr == NULL) {
Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
} else if (objPtr == dictPtr) {
/*
* Someone is messing us around, trying to build a recursive
|
| ︙ | ︙ | |||
3526 3527 3528 3529 3530 3531 3532 |
/*
* Save the result state; TDWF doesn't guarantee to not modify that on
* TCL_OK result.
*/
state = Tcl_SaveInterpState(interp, result);
if (pathPtr != NULL) {
| | | 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 |
/*
* Save the result state; TDWF doesn't guarantee to not modify that on
* TCL_OK result.
*/
state = Tcl_SaveInterpState(interp, result);
if (pathPtr != NULL) {
TclListObjGetElements(NULL, pathPtr, &pathc, &pathv);
} else {
pathc = 0;
pathv = NULL;
}
/*
* Pack from local variables back into the dictionary.
|
| ︙ | ︙ | |||
3732 3733 3734 3735 3736 3737 3738 |
leafPtr = dictPtr;
}
/*
* Now process our updates on the leaf dictionary.
*/
| | | 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 |
leafPtr = dictPtr;
}
/*
* Now process our updates on the leaf dictionary.
*/
TclListObjGetElements(NULL, keysPtr, &keyc, &keyv);
for (i=0 ; i<keyc ; i++) {
valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
if (valPtr == NULL) {
Tcl_DictObjRemove(NULL, leafPtr, keyv[i]);
} else if (leafPtr == valPtr) {
/*
* Someone is messing us around, trying to build a recursive
|
| ︙ | ︙ | |||
3796 3797 3798 3799 3800 3801 3802 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclDisassemble.c.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInstName, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
| | | | | | | | | | < | 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 |
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInstName, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define InstNameSetInternalRep(objPtr, inst) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (inst); \
Tcl_StoreInternalRep((objPtr), &instNameType, &ir); \
} while (0)
#define InstNameGetInternalRep(objPtr, inst) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &instNameType); \
assert(irPtr != NULL); \
(inst) = irPtr->wideValue; \
} while (0)
/*
*----------------------------------------------------------------------
*
* GetLocationInformation --
*
* This procedure looks up the information about where a procedure was
|
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
}
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
| | | < > | | | > > | 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 |
}
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* TclDebugPrintByteCodeObj --
*
* This procedure prints ("disassembles") the instructions of a bytecode
* object to stdout.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclDebugPrintByteCodeObj(
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
if (tclTraceCompile >= 2) {
Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
fflush(stdout);
}
}
/*
*----------------------------------------------------------------------
*
* TclPrintInstruction --
*
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
Tcl_Obj *objPtr, /* Points to the Tcl object whose string
* representation should be printed. */
Tcl_Size maxChars) /* Maximum number of chars to print. */
{
char *bytes;
Tcl_Size length;
| | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 |
Tcl_Obj *objPtr, /* Points to the Tcl object whose string
* representation should be printed. */
Tcl_Size maxChars) /* Maximum number of chars to print. */
{
char *bytes;
Tcl_Size length;
bytes = TclGetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
/*
*----------------------------------------------------------------------
*
* TclPrintSource --
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 |
}
}
if (suffixObj) {
const char *bytes;
Tcl_Size length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
| | | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
}
}
if (suffixObj) {
const char *bytes;
Tcl_Size length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length);
PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
} else if (suffixBuffer[0]) {
Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
if (suffixSrc) {
PrintSourceToObj(bufferObj, suffixSrc, 40);
}
}
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 |
case INST_LNOT:
case INST_BITNOT:
case INST_UMINUS:
case INST_UPLUS:
case INST_TRY_CVT_TO_NUMERIC:
case INST_EXPAND_STKTOP:
case INST_EXPR_STK:
| | | | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
case INST_LNOT:
case INST_BITNOT:
case INST_UMINUS:
case INST_UPLUS:
case INST_TRY_CVT_TO_NUMERIC:
case INST_EXPAND_STKTOP:
case INST_EXPR_STK:
objc = 1;
break;
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
case INST_STR_EQ:
case INST_STR_NEQ: /* String (in)equality check */
case INST_STR_CMP: /* String compare. */
case INST_STR_INDEX:
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 |
case INST_BITXOR:
case INST_BITAND:
case INST_EXPON:
case INST_ADD:
case INST_SUB:
case INST_DIV:
case INST_MULT:
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
case INST_BITXOR:
case INST_BITAND:
case INST_EXPON:
case INST_ADD:
case INST_SUB:
case INST_DIV:
case INST_MULT:
objc = 2;
break;
case INST_RETURN_STK:
/* early pop. TODO: dig out opt dict too :/ */
objc = 1;
break;
case INST_SYNTAX:
case INST_RETURN_IMM:
objc = 2;
break;
case INST_INVOKE_STK4:
objc = TclGetUInt4AtPtr(pc+1);
break;
case INST_INVOKE_STK1:
objc = TclGetUInt1AtPtr(pc+1);
break;
}
result = iPtr->innerContext;
if (Tcl_IsShared(result)) {
Tcl_DecrRefCount(result);
iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
Tcl_IncrRefCount(result);
} else {
Tcl_Size len;
/*
* Reset while keeping the list internalrep as much as possible.
*/
TclListObjLength(interp, result, &len);
Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
}
Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
for (; objc>0 ; objc--) {
Tcl_Obj *objPtr;
objPtr = tosPtr[1 - objc];
if (!objPtr) {
Tcl_Panic("InnerContext: bad tos -- appending null object");
}
if ((objPtr->refCount <= 0)
#ifdef TCL_MEM_DEBUG
|| (objPtr->refCount == 0x61616161)
#endif
) {
Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
objPtr);
}
Tcl_ListObjAppendElement(NULL, result, objPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
833 834 835 836 837 838 839 |
char *dst;
InstNameGetInternalRep(objPtr, inst);
if (inst >= LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, TCL_INTEGER_SPACE + 5);
| | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
char *dst;
InstNameGetInternalRep(objPtr, inst);
if (inst >= LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, TCL_INTEGER_SPACE + 5);
snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
const char *s = tclInstructionTable[inst].name;
size_t len = strlen(s);
dst = Tcl_InitStringRep(objPtr, s, len);
TclOOM(dst, len);
}
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
}
Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
| | | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 |
}
Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
len = TclUtfToUniChar(p, &ucs4);
switch (ucs4) {
case '"':
Tcl_AppendToObj(appendObj, "\\\"", -1);
i += 2;
continue;
case '\f':
Tcl_AppendToObj(appendObj, "\\f", -1);
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 |
AuxData *auxData = &codePtr->auxDataArrayPtr[i];
Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);
if (auxData->type->disassembleProc) {
Tcl_Obj *desc;
TclNewObj(desc);
| | | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 |
AuxData *auxData = &codePtr->auxDataArrayPtr[i];
Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);
if (auxData->type->disassembleProc) {
Tcl_Obj *desc;
TclNewObj(desc);
TclDictPut(NULL, desc, "name", auxDesc);
auxDesc = desc;
auxData->type->disassembleProc(auxData->clientData, auxDesc,
codePtr, 0);
} else if (auxData->type->printProc) {
Tcl_Obj *desc;
TclNewObj(desc);
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 | Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); codeLength = Decode(codeLenPtr); sourceOffset += Decode(srcOffPtr); sourceLength = Decode(srcLenPtr); TclNewObj(cmd); | < | | | | | < < | | | | < | < | | < | | < | | | | | | < | < | 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 |
Tcl_Obj *cmd;
codeOffset += Decode(codeOffPtr);
codeLength = Decode(codeLenPtr);
sourceOffset += Decode(srcOffPtr);
sourceLength = Decode(srcLenPtr);
TclNewObj(cmd);
TclDictPut(NULL, cmd, "codefrom", Tcl_NewWideIntObj(codeOffset));
TclDictPut(NULL, cmd, "codeto", Tcl_NewWideIntObj(
codeOffset + codeLength - 1));
/*
* Convert byte offsets to character offsets; important if multibyte
* characters are present in the source!
*/
TclDictPut(NULL, cmd, "scriptfrom", Tcl_NewWideIntObj(
Tcl_NumUtfChars(codePtr->source, sourceOffset)));
TclDictPut(NULL, cmd, "scriptto", Tcl_NewWideIntObj(
Tcl_NumUtfChars(codePtr->source, sourceOffset + sourceLength - 1)));
TclDictPut(NULL, cmd, "script",
Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
Tcl_ListObjAppendElement(NULL, commands, cmd);
}
#undef Decode
/*
* Get the source file and line number information from the CmdFrame
* system if it is available.
*/
GetLocationInformation(codePtr->procPtr, &file, &line);
/*
* Build the overall result.
*/
TclNewObj(description);
TclDictPut(NULL, description, "literals", literals);
TclDictPut(NULL, description, "variables", variables);
TclDictPut(NULL, description, "exception", exn);
TclDictPut(NULL, description, "instructions", instructions);
TclDictPut(NULL, description, "auxiliary", aux);
TclDictPut(NULL, description, "commands", commands);
TclDictPut(NULL, description, "script",
Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
TclDictPut(NULL, description, "namespace",
TclNewNamespaceObj((Tcl_Namespace *) codePtr->nsPtr));
TclDictPut(NULL, description, "stackdepth",
Tcl_NewWideIntObj(codePtr->maxStackDepth));
TclDictPut(NULL, description, "exceptdepth",
Tcl_NewWideIntObj(codePtr->maxExceptDepth));
if (line >= 0) {
TclDictPut(NULL, description, "initiallinenumber",
Tcl_NewWideIntObj(line));
}
if (file) {
TclDictPut(NULL, description, "sourcefile", file);
}
return description;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1341 1342 1343 1344 1345 1346 1347 |
}
procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
| | | 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 |
}
procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
/*
* Compile (if uncompiled) and disassemble a procedure.
*/
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
| | | | | 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 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
methodPtr = oPtr->classPtr->constructorPtr;
if (methodPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" has no defined constructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"CONSRUCTOR", (char *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", (char *)NULL);
return TCL_ERROR;
}
/*
* Compile if necessary.
*/
|
| ︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
| | | | | 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
methodPtr = oPtr->classPtr->destructorPtr;
if (methodPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" has no defined destructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"DESRUCTOR", (char *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of destructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", (char *)NULL);
return TCL_ERROR;
}
/*
* Compile if necessary.
*/
|
| ︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
| | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
objv[3]);
goto methodBody;
case DISAS_OBJECT_METHOD:
if (objc != 4) {
|
| ︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 |
methodBody:
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
| | | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 |
methodBody:
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[3]), (char *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", (char *)NULL);
return TCL_ERROR;
}
if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
* Yes, this is ugly, but we need to pass the namespace in to the
|
| ︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 |
ByteCodeGetInternalRep(codeObjPtr, &tclByteCodeType, codePtr);
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
| | | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 |
ByteCodeGetInternalRep(codeObjPtr, &tclByteCodeType, codePtr);
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", (char *)NULL);
return TCL_ERROR;
}
if (clientData) {
Tcl_SetObjResult(interp,
DisassembleByteCodeAsDicts(codeObjPtr));
} else {
Tcl_SetObjResult(interp,
|
| ︙ | ︙ |
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
* into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Function to convert from UTF-8 into
* external encoding. */
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, function to call when this
* encoding is deleted. */
| | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
* into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Function to convert from UTF-8 into
* external encoding. */
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, function to call when this
* encoding is deleted. */
void *clientData; /* Arbitrary value associated with encoding
* type. Passed to conversion functions. */
Tcl_Size nullSize; /* Number of 0x00 bytes that signify
* end-of-string in this encoding. This number
* is used to determine the source string
* length when the srcLen argument is
* negative. This number can be 1, 2, or 4. */
LengthProc *lengthProc; /* Function to compute length of
* null-terminated strings in this encoding.
* If nullSize is 1, this is strlen; if
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
* conversion. */
char prefixBytes[256]; /* If a byte in the input stream is the first
* character of one of the escape sequences in
* the following array, the corresponding
* entry in this array is 1, otherwise it is
* 0. */
int numSubTables; /* Length of following array. */
| | > | | | | | | > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
* conversion. */
char prefixBytes[256]; /* If a byte in the input stream is the first
* character of one of the escape sequences in
* the following array, the corresponding
* entry in this array is 1, otherwise it is
* 0. */
int numSubTables; /* Length of following array. */
EscapeSubTable subTables[TCLFLEXARRAY];
/* Information about each EscapeSubTable used
* by this encoding type. The actual size is
* as large as necessary to hold all
* EscapeSubTables. */
} EscapeEncodingData;
/*
* Values used when loading an encoding file to identify the type of the
* file.
*/
enum EncodingTypes {
ENCODING_SINGLEBYTE = 0, /* Encoding is single byte per character. */
ENCODING_DOUBLEBYTE = 1, /* Encoding is two bytes per character. */
ENCODING_MULTIBYTE = 2, /* Encoding is variable bytes per character. */
ENCODING_ESCAPE = 3 /* Encoding has modes with escapes to move
* between them. */
};
/*
* A list of directories in which Tcl should look for *.enc files. This list
* is shared by all threads. Access is governed by a mutex lock.
*/
static TclInitProcessGlobalValueProc InitializeEncodingSearchPath;
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
int value;
} encodingProfiles[] = {
{"replace", TCL_ENCODING_PROFILE_REPLACE},
{"strict", TCL_ENCODING_PROFILE_STRICT},
{"tcl8", TCL_ENCODING_PROFILE_TCL8},
};
| | | | | | | | 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 |
int value;
} encodingProfiles[] = {
{"replace", TCL_ENCODING_PROFILE_REPLACE},
{"strict", TCL_ENCODING_PROFILE_STRICT},
{"tcl8", TCL_ENCODING_PROFILE_TCL8},
};
#define PROFILE_TCL8(flags_) \
(ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8)
#define PROFILE_REPLACE(flags_) \
(ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE)
#define PROFILE_STRICT(flags_) \
(!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_))
#define UNICODE_REPLACE_CHAR 0xFFFD
#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800)
#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800)
#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00)
/*
* The following variable is used in the sparse matrix code for a
* TableEncoding to represent a page in the table that has no entries.
*/
static unsigned short emptyPage[256];
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | static Tcl_EncodingConvertProc Utf16ToUtfProc; static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; | < | | | | | | | | < | 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 |
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].
*/
static const Tcl_ObjType encodingType = {
"encoding",
FreeEncodingInternalRep,
DupEncodingInternalRep,
NULL,
NULL,
TCL_OBJTYPE_V0
};
#define EncodingSetInternalRep(objPtr, encoding) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (encoding); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &encodingType, &ir); \
} while (0)
#define EncodingGetInternalRep(objPtr, encoding) \
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
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 |
int
Tcl_SetEncodingSearchPath(
Tcl_Obj *searchPath)
{
Tcl_Size dummy;
| | | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
int
Tcl_SetEncodingSearchPath(
Tcl_Obj *searchPath)
{
Tcl_Size dummy;
if (TCL_ERROR == TclListObjLength(NULL, searchPath, &dummy)) {
return TCL_ERROR;
}
TclSetProcessGlobalValue(&encodingSearchPath, searchPath);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* FillEncodingFileMap --
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 |
FillEncodingFileMap(void)
{
Tcl_Size i, numDirs = 0;
Tcl_Obj *map, *searchPath;
searchPath = Tcl_GetEncodingSearchPath();
Tcl_IncrRefCount(searchPath);
| | | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
FillEncodingFileMap(void)
{
Tcl_Size i, numDirs = 0;
Tcl_Obj *map, *searchPath;
searchPath = Tcl_GetEncodingSearchPath();
Tcl_IncrRefCount(searchPath);
TclListObjLength(NULL, searchPath, &numDirs);
map = Tcl_NewDictObj();
Tcl_IncrRefCount(map);
for (i = numDirs-1; i != TCL_INDEX_NONE; i--) {
/*
* Iterate backwards through the search path so as we overwrite
* entries found, we favor files earlier on the search path.
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 | TclNewObj(matchFileList); Tcl_ListObjIndex(NULL, searchPath, i, &directory); Tcl_IncrRefCount(directory); Tcl_IncrRefCount(matchFileList); Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc", &readableFiles); | | | | | | | | 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 |
TclNewObj(matchFileList);
Tcl_ListObjIndex(NULL, searchPath, i, &directory);
Tcl_IncrRefCount(directory);
Tcl_IncrRefCount(matchFileList);
Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc",
&readableFiles);
TclListObjGetElements(NULL, matchFileList, &numFiles, &filev);
for (j=0; j<numFiles; j++) {
Tcl_Obj *encoding, *fileObj;
fileObj = TclPathPart(NULL, filev[j], TCL_PATH_TAIL);
encoding = TclPathPart(NULL, fileObj, TCL_PATH_ROOT);
Tcl_DictObjPut(NULL, map, encoding, directory);
Tcl_DecrRefCount(fileObj);
Tcl_DecrRefCount(encoding);
}
Tcl_DecrRefCount(matchFileList);
Tcl_DecrRefCount(directory);
}
Tcl_DecrRefCount(searchPath);
TclSetProcessGlobalValue(&encodingFileMap, map);
Tcl_DecrRefCount(map);
}
/*
*---------------------------------------------------------------------------
*
* TclInitEncodingSubsystem --
|
| ︙ | ︙ | |||
508 509 510 511 512 513 514 | /* * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this * when adding bits. TODO - should really be defined in a single file. * * To prevent conflicting bits, only define bits within 0xff00 mask here. */ | > | | > | > > | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 |
/*
* NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS
* DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this
* when adding bits. TODO - should really be defined in a single file.
*
* To prevent conflicting bits, only define bits within 0xff00 mask here.
*/
enum InternalEncodingFlags {
TCL_ENCODING_LE = 0x100, /* Used to distinguish LE/BE variants */
ENCODING_UTF = 0x200, /* For UTF-8 encoding, allow 4-byte output
* sequences */
ENCODING_INPUT = 0x400 /* For UTF-8/CESU-8 encoding, means
* external -> internal */
};
void
TclInitEncodingSubsystem(void)
{
Tcl_EncodingType type;
TableEncodingData *dataPtr;
unsigned size;
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 |
type.clientData = INT2PTR(ENCODING_UTF);
tclUtf8Encoding = Tcl_CreateEncoding(&type);
type.clientData = NULL;
type.encodingName = "cesu-8";
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
| | | | | | | | | | | | | | 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 |
type.clientData = INT2PTR(ENCODING_UTF);
tclUtf8Encoding = Tcl_CreateEncoding(&type);
type.clientData = NULL;
type.encodingName = "cesu-8";
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
type.fromUtfProc = UtfToUcs2Proc;
type.freeProc = NULL;
type.nullSize = 2;
type.encodingName = "ucs-2le";
type.clientData = INT2PTR(TCL_ENCODING_LE);
Tcl_CreateEncoding(&type);
type.encodingName = "ucs-2be";
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "ucs-2";
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf32ToUtfProc;
type.fromUtfProc = UtfToUtf32Proc;
type.freeProc = NULL;
type.nullSize = 4;
type.encodingName = "utf-32le";
type.clientData = INT2PTR(TCL_ENCODING_LE);
Tcl_CreateEncoding(&type);
type.encodingName = "utf-32be";
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "utf-32";
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
type.fromUtfProc = UtfToUtf16Proc;
type.freeProc = NULL;
type.nullSize = 2;
type.encodingName = "utf-16le";
type.clientData = INT2PTR(TCL_ENCODING_LE);
Tcl_CreateEncoding(&type);
type.encodingName = "utf-16be";
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "utf-16";
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
#ifndef TCL_NO_DEPRECATED
type.encodingName = "unicode";
Tcl_CreateEncoding(&type);
#endif
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
* table encoding or some of the escape encodings crash! Hence the ugly
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the | | | 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the * string termination. * * Results: * The number of nul bytes used for the string termination. * * Side effects: * None. * |
| ︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 |
encodingPtr->lengthProc = (LengthProc *) unilen4;
} else {
encodingPtr->lengthProc = (LengthProc *) strlen;
}
encodingPtr->refCount = 1;
encodingPtr->hPtr = NULL;
| | | | | | | | | | | | | | | | | | | | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 |
encodingPtr->lengthProc = (LengthProc *) unilen4;
} else {
encodingPtr->lengthProc = (LengthProc *) strlen;
}
encodingPtr->refCount = 1;
encodingPtr->hPtr = NULL;
if (typePtr->encodingName) {
Tcl_HashEntry *hPtr;
int isNew;
char *name;
Tcl_MutexLock(&encodingMutex);
hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew);
if (isNew == 0) {
/*
* Remove old encoding from hash table, but don't delete it until last
* reference goes away.
*/
Encoding *replaceMe = (Encoding *)Tcl_GetHashValue(hPtr);
replaceMe->hPtr = NULL;
}
name = (char *)Tcl_Alloc(strlen(typePtr->encodingName) + 1);
encodingPtr->name = strcpy(name, typePtr->encodingName);
encodingPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, encodingPtr);
Tcl_MutexUnlock(&encodingMutex);
}
return (Tcl_Encoding) encodingPtr;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_ExternalToUtfDString --
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_ExternalToUtfDStringEx(
NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
return Tcl_DStringValue(dstPtr);
}
| < | | | | | | | < | | | | | | | | | | | | | | | < < < < < < < < < < < < > | 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 |
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_ExternalToUtfDStringEx(
NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
return Tcl_DStringValue(dstPtr);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_ExternalToUtfDStringEx --
*
* Convert a source buffer from the specified encoding into UTF-8.
* "flags" controls the behavior if any of the bytes in
* the source buffer are invalid or cannot be represented in utf-8.
* Possible flags values:
* target encoding. It should be composed by OR-ing the following:
* - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT}
*
* Results:
* The return value is one of
* TCL_OK: success. Converted string in *dstPtr
* TCL_ERROR: error in passed parameters. Error message in interp
* TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
* TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
* TCL_CONVERT_UNKNOWN: source contained a character that could not
* be represented in target encoding.
*
* Side effects:
* TCL_OK: The converted bytes are stored in the DString and NUL
* terminated in an encoding-specific manner.
* TCL_ERROR: an error, message is stored in the interp if not NULL.
* TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
* in the interpreter (if not NULL). If errorLocPtr is not NULL,
* no error message is stored as it is expected the caller is
* interested in whatever is decoded so far and not treating this
* as an error condition.
*
* In addition, *dstPtr is always initialized and must be cleared
* by the caller irrespective of the return code.
*
*-------------------------------------------------------------------------
*/
int
Tcl_ExternalToUtfDStringEx(
Tcl_Interp *interp, /* For error messages. May be NULL. */
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
int flags, /* Conversion control flags. */
Tcl_DString *dstPtr, /* Uninitialized or free DString in which the
* converted string is stored. */
Tcl_Size *errorLocPtr) /* Where to store the error location
* (or TCL_INDEX_NONE if no error). May
* be NULL. */
{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
int result;
Tcl_Size dstLen, soFar;
const char *srcStart = src;
/* DO FIRST - Must always be initialized before returning */
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *)encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_INDEX_NONE) {
srcLen = encodingPtr->lengthProc(src);
}
flags &= ~TCL_ENCODING_END;
flags |= TCL_ENCODING_START;
if (encodingPtr->toUtfProc == UtfToUtfProc) {
flags |= ENCODING_INPUT;
}
while (1) {
int srcChunkLen, srcChunkRead;
|
| ︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 | * - our destination buffer did not have enough room * - we had not passed in all the data and error indicated fragment * of a multibyte character * In both cases we have to grow buffer, move the input source pointer * and loop. Otherwise, return the result we got. */ if ((result != TCL_CONVERT_NOSPACE) && | | | > | > | < | | < | | > | 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 |
* - our destination buffer did not have enough room
* - we had not passed in all the data and error indicated fragment
* of a multibyte character
* In both cases we have to grow buffer, move the input source pointer
* and loop. Otherwise, return the result we got.
*/
if ((result != TCL_CONVERT_NOSPACE) &&
!(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) {
Tcl_Size nBytesProcessed = (src - srcStart);
Tcl_DStringSetLength(dstPtr, soFar);
if (errorLocPtr) {
/*
* Do not write error message into interpreter if caller
* wants to know error location.
*/
*errorLocPtr = result == TCL_OK
? TCL_INDEX_NONE : nBytesProcessed;
} else {
/* Caller wants error message on failure */
if (result != TCL_OK && interp != NULL) {
char buf[TCL_INTEGER_SPACE];
snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d",
nBytesProcessed);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unexpected byte sequence starting at index %"
TCL_SIZE_MODIFIER "d: '\\x%02X'",
nBytesProcessed, UCHAR(srcStart[nBytesProcessed])));
Tcl_SetErrorCode(
interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf,
(char *)NULL);
}
}
if (result != TCL_OK) {
errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ;
}
return result;
}
|
| ︙ | ︙ | |||
1299 1300 1301 1302 1303 1304 1305 |
int
Tcl_ExternalToUtf(
TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
| | | > | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
int
Tcl_ExternalToUtf(
TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
Tcl_Size srcLen, /* Source string length in bytes, or
* TCL_INDEX_NONE for encoding-specific string
* length. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst, /* Output buffer in which converted string is
|
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_UtfToExternalDStringEx(
NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
return Tcl_DStringValue(dstPtr);
}
| < | | | | | | | < | | | | | | | | | | | | | | < < < < < < < < < < < < > | | | | > > | | > | < < < | | | 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 |
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_UtfToExternalDStringEx(
NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
return Tcl_DStringValue(dstPtr);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_UtfToExternalDStringEx --
*
* Convert a source buffer from UTF-8 to the specified encoding.
* The parameter flags controls the behavior, if any of the bytes in
* the source buffer are invalid or cannot be represented in the
* target encoding. It should be composed by OR-ing the following:
* - *At most one* of TCL_ENCODING_PROFILE_*
*
* Results:
* The return value is one of
* TCL_OK: success. Converted string in *dstPtr
* TCL_ERROR: error in passed parameters. Error message in interp
* TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
* TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
* TCL_CONVERT_UNKNOWN: source contained a character that could not
* be represented in target encoding.
*
* Side effects:
* TCL_OK: The converted bytes are stored in the DString and NUL
* terminated in an encoding-specific manner
* TCL_ERROR: an error, message is stored in the interp if not NULL.
* TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
* in the interpreter (if not NULL). If errorLocPtr is not NULL,
* no error message is stored as it is expected the caller is
* interested in whatever is decoded so far and not treating this
* as an error condition.
*
* In addition, *dstPtr is always initialized and must be cleared
* by the caller irrespective of the return code.
*
*-------------------------------------------------------------------------
*/
int
Tcl_UtfToExternalDStringEx(
Tcl_Interp *interp, /* For error messages. May be NULL. */
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
int flags, /* Conversion control flags. */
Tcl_DString *dstPtr, /* Uninitialized or free DString in which the
* converted string is stored. */
Tcl_Size *errorLocPtr) /* Where to store the error location
* (or TCL_INDEX_NONE if no error). May
* be NULL. */
{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
int result;
const char *srcStart = src;
Tcl_Size dstLen, soFar;
/* DO FIRST - must always be initialized on return */
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen == TCL_INDEX_NONE) {
srcLen = strlen(src);
}
flags &= ~TCL_ENCODING_END;
flags |= TCL_ENCODING_START;
while (1) {
int srcChunkLen, srcChunkRead;
int dstChunkLen, dstChunkWrote, dstChunkChars;
if (srcLen > INT_MAX) {
srcChunkLen = INT_MAX;
} else {
srcChunkLen = srcLen;
flags |= TCL_ENCODING_END; /* Last chunk */
}
dstChunkLen = dstLen > INT_MAX ? INT_MAX : dstLen;
result = encodingPtr->fromUtfProc(encodingPtr->clientData, src,
srcChunkLen, flags, &state, dst, dstChunkLen,
&srcChunkRead, &dstChunkWrote, &dstChunkChars);
soFar = dst + dstChunkWrote - Tcl_DStringValue(dstPtr);
/* Move past the part processed in this go around */
src += srcChunkRead;
/*
* Keep looping in two case -
* - our destination buffer did not have enough room
* - we had not passed in all the data and error indicated fragment
* of a multibyte character
* In both cases we have to grow buffer, move the input source pointer
* and loop. Otherwise, return the result we got.
*/
if ((result != TCL_CONVERT_NOSPACE) &&
!(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) {
Tcl_Size nBytesProcessed = (src - srcStart);
Tcl_Size i = soFar + encodingPtr->nullSize - 1;
/* Loop as DStringSetLength only stores one nul byte at a time */
while (i >= soFar) {
Tcl_DStringSetLength(dstPtr, i--);
}
if (errorLocPtr) {
/*
* Do not write error message into interpreter if caller
* wants to know error location.
*/
*errorLocPtr = result == TCL_OK
? TCL_INDEX_NONE : nBytesProcessed;
} else {
/* Caller wants error message on failure */
if (result != TCL_OK && interp != NULL) {
Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed);
int ucs4;
char buf[TCL_INTEGER_SPACE];
TclUtfToUniChar(&srcStart[nBytesProcessed], &ucs4);
snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d",
nBytesProcessed);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unexpected character at index %" TCL_SIZE_MODIFIER
"u: 'U+%06X'",
pos, ucs4));
Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
buf, (char *)NULL);
}
}
if (result != TCL_OK) {
errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ;
}
return result;
}
|
| ︙ | ︙ | |||
1633 1634 1635 1636 1637 1638 1639 |
int
Tcl_UtfToExternal(
TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
| | | | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 |
int
Tcl_UtfToExternal(
TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
Tcl_Size srcLen, /* Source string length in bytes, or
* TCL_INDEX_NONE for strlen(). */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst, /* Output buffer in which converted string
|
| ︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 |
static Tcl_Channel
OpenEncodingFileChannel(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
const char *name) /* The name of the encoding file on disk and
* also the name for new encoding. */
{
| < | | < < | | 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
static Tcl_Channel
OpenEncodingFileChannel(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
const char *name) /* The name of the encoding file on disk and
* also the name for new encoding. */
{
Tcl_Obj *fileNameObj = Tcl_ObjPrintf("%s.enc", name);
Tcl_Obj *searchPath = Tcl_DuplicateObj(Tcl_GetEncodingSearchPath());
Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap);
Tcl_Obj **dir, *path, *directory = NULL;
Tcl_Channel chan = NULL;
Tcl_Size i, numDirs;
TclListObjGetElements(NULL, searchPath, &numDirs, &dir);
Tcl_IncrRefCount(fileNameObj);
TclDictGet(NULL, map, name, &directory);
/*
* Check that any cached directory is still on the encoding search path.
*/
if (NULL != directory) {
int verified = 0;
|
| ︙ | ︙ | |||
1803 1804 1805 1806 1807 1808 1809 |
}
if (!verified) {
/*
* Directory no longer on the search path. Remove from cache.
*/
map = Tcl_DuplicateObj(map);
| | | | 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 |
}
if (!verified) {
/*
* Directory no longer on the search path. Remove from cache.
*/
map = Tcl_DuplicateObj(map);
TclDictRemove(NULL, map, name);
TclSetProcessGlobalValue(&encodingFileMap, map);
directory = NULL;
}
}
if (NULL != directory) {
/*
* Got a directory from the cache. Try to use it first.
|
| ︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 |
Tcl_DecrRefCount(path);
if (chan != NULL) {
/*
* Save directory in the cache.
*/
map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap));
| | | | < | 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 |
Tcl_DecrRefCount(path);
if (chan != NULL) {
/*
* Save directory in the cache.
*/
map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap));
TclDictPut(NULL, map, name, dir[i]);
TclSetProcessGlobalValue(&encodingFileMap, map);
}
}
if ((NULL == chan) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown encoding \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (char *)NULL);
}
Tcl_DecrRefCount(fileNameObj);
Tcl_DecrRefCount(searchPath);
return chan;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 |
case 'E':
encoding = LoadEscapeEncoding(name, chan);
break;
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid encoding file \"%s\"", name));
| | | | 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 |
case 'E':
encoding = LoadEscapeEncoding(name, chan);
break;
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid encoding file \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (char *)NULL);
}
Tcl_CloseEx(NULL, chan, 0);
return encoding;
}
/*
*-------------------------------------------------------------------------
*
* LoadTableEncoding --
*
* Helper function for LoadEncodingFile(). Creates a Tcl_EncodingType
* structure along with its corresponding TableEncodingData structure, and
* passes it to Tcl_Createncoding.
*
* The file contains binary data but begins with a marker to indicate
* byte-ordering so a single binary file can be read on big or
* little-endian systems.
*
* Results:
* Returns the new Tcl_Encoding, or NULL if it could
* not be created because the file contained invalid data.
*
* Side effects:
* See Tcl_CreateEncoding().
*
*-------------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 |
/*
* To avoid infinite recursion in [encoding system iso2022-*]
*/
e = (Encoding *) Tcl_GetEncoding(NULL, est.name);
if ((e != NULL) && (e->toUtfProc != TableToUtfProc)
&& (e->toUtfProc != Iso88591ToUtfProc)) {
| | | | 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 |
/*
* To avoid infinite recursion in [encoding system iso2022-*]
*/
e = (Encoding *) Tcl_GetEncoding(NULL, est.name);
if ((e != NULL) && (e->toUtfProc != TableToUtfProc)
&& (e->toUtfProc != Iso88591ToUtfProc)) {
Tcl_FreeEncoding((Tcl_Encoding) e);
e = NULL;
}
est.encodingPtr = e;
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
Tcl_Free(argv);
Tcl_DStringFree(&lineString);
|
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 |
static int
UtfToUtfProc(
void *clientData, /* additional flags */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* TCL_ENCODING_* conversion control flags. */
| | > > > > | 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 |
static int
UtfToUtfProc(
void *clientData, /* additional flags */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* TCL_ENCODING_* conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
|
| ︙ | ︙ | |||
2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 |
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
int ch;
int profile;
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= 6;
}
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
dstStart = dst;
flags |= PTR2INT(clientData);
| > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < < | | > > | | | > | > > > > | > > > | > > | | > | | | | > > | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 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 2722 2723 2724 |
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
int ch;
int profile;
if (flags & TCL_ENCODING_START) {
/* *statePtr will hold high surrogate in a split surrogate pair */
*statePtr = 0;
}
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= 6;
}
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
dstStart = dst;
flags |= PTR2INT(clientData);
/*
* If output is UTF-8 or encoding for Tcl's internal encoding,
* max space needed is TCL_UTF_MAX. Otherwise, need 6 bytes (CESU-8)
*/
dstEnd = dst + dstLen - ((flags & (ENCODING_INPUT|ENCODING_UTF)) ? TCL_UTF_MAX : 6);
/*
* Macro to output an isolated high surrogate when it is not followed
* by a low surrogate. NOT to be called for strict profile since
* that should raise an error.
*/
#define OUTPUT_ISOLATEDSURROGATE \
do { \
Tcl_UniChar high; \
if (PROFILE_REPLACE(profile)) { \
high = UNICODE_REPLACE_CHAR; \
} else { \
high = (Tcl_UniChar)(ptrdiff_t) *statePtr; \
} \
assert(!(flags & ENCODING_UTF)); /* Must be CESU-8 */ \
assert(HIGH_SURROGATE(high)); \
assert(!PROFILE_STRICT(profile)); \
dst += Tcl_UniCharToUtf(high, dst); \
*statePtr = 0; /* Reset state */ \
} while (0)
/*
* Macro to check for isolated surrogate and either break with
* an error if profile is strict, or output an appropriate
* character for replace and tcl8 profiles and continue.
*/
#define CHECK_ISOLATEDSURROGATE \
if (*statePtr) { \
if (PROFILE_STRICT(profile)) { \
result = TCL_CONVERT_SYNTAX; \
break; \
} \
OUTPUT_ISOLATEDSURROGATE; \
continue; /* Rerun loop so length checks etc. repeated */ \
} else \
(void) 0
profile = ENCODING_PROFILE_GET(flags);
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) {
CHECK_ISOLATEDSURROGATE;
/*
* Copy 7bit characters, but skip null-bytes when we are in input
* mode, so that they get converted to \xC0\x80.
*/
*dst++ = *src++;
} else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) &&
(UCHAR(src[1]) == 0x80) &&
(!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) {
/* Special sequence \xC0\x80 */
CHECK_ISOLATEDSURROGATE;
if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) {
if (PROFILE_REPLACE(profile)) {
dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
src += 2;
} else {
/* PROFILE_STRICT */
result = TCL_CONVERT_SYNTAX;
break;
}
} else {
/*
* Convert 0xC080 to real nulls when we are in output mode,
* irrespective of the profile.
*/
*dst++ = 0;
src += 2;
}
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/*
* Incomplete byte sequence not because there are insufficient
* bytes in source buffer (have already checked that above) but
* because the UTF-8 sequence is truncated.
*/
CHECK_ISOLATEDSURROGATE;
if (flags & ENCODING_INPUT) {
/* Incomplete bytes for modified UTF-8 target */
if (PROFILE_STRICT(profile)) {
result = (flags & TCL_ENCODING_CHAR_LIMIT)
? TCL_CONVERT_MULTIBYTE
: TCL_CONVERT_SYNTAX;
break;
}
}
if (PROFILE_REPLACE(profile)) {
ch = UNICODE_REPLACE_CHAR;
++src;
} else {
/* TCL_ENCODING_PROFILE_TCL8 */
char chbuf[2];
chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
TclUtfToUniChar(chbuf, &ch);
}
dst += Tcl_UniCharToUtf(ch, dst);
} else {
/* Have a complete character */
size_t len = TclUtfToUniChar(src, &ch);
Tcl_UniChar savedSurrogate = (Tcl_UniChar) (ptrdiff_t)*statePtr;
*statePtr = 0; /* Reset surrogate */
if (flags & ENCODING_INPUT) {
if (((len < 2) && (ch != 0)) || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) {
if (PROFILE_STRICT(profile)) {
result = TCL_CONVERT_SYNTAX;
break;
} else if (PROFILE_REPLACE(profile)) {
ch = UNICODE_REPLACE_CHAR;
}
}
}
const char *saveSrc = src;
src += len;
if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT)
&& (ch > 0x7FF)) {
assert(savedSurrogate == 0); /* Since this flag combo
will never set *statePtr */
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 & 0x03FF) | 0xDC00;
}
*dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF);
*dst++ = (char)(((ch >> 6) | 0x80) & 0xBF);
*dst++ = (char)((ch | 0x80) & 0xBF);
continue;
} else if (SURROGATE(ch)) {
if ((flags & ENCODING_UTF)) {
/* UTF-8, not CESU-8, so surrogates should not appear */
if (PROFILE_STRICT(profile)) {
result = (flags & ENCODING_INPUT)
? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
src = saveSrc;
break;
} else if (PROFILE_REPLACE(profile)) {
ch = UNICODE_REPLACE_CHAR;
} else {
/* PROFILE_TCL8 - output as is */
}
} else {
/* CESU-8 */
if (LOW_SURROGATE(ch)) {
if (savedSurrogate) {
assert(HIGH_SURROGATE(savedSurrogate));
ch = 0x10000 + ((savedSurrogate - 0xd800) << 10) + (ch - 0xdc00);
} else {
/* Isolated low surrogate */
if (PROFILE_STRICT(profile)) {
result = (flags & ENCODING_INPUT)
? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
src = saveSrc;
break;
} else if (PROFILE_REPLACE(profile)) {
ch = UNICODE_REPLACE_CHAR;
} else {
/* Tcl8 profile. Output low surrogate as is */
}
}
} else {
assert(HIGH_SURROGATE(ch));
/* Save the high surrogate */
*statePtr = (Tcl_EncodingState) (ptrdiff_t) ch;
if (savedSurrogate) {
assert(HIGH_SURROGATE(savedSurrogate));
if (PROFILE_STRICT(profile)) {
result = (flags & ENCODING_INPUT)
? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
src = saveSrc;
break;
} else if (PROFILE_REPLACE(profile)) {
ch = UNICODE_REPLACE_CHAR;
} else {
/* Output the isolated high surrogate */
ch = savedSurrogate;
}
} else {
/* High surrogate saved in *statePtr. Do not output anything just yet. */
--numChars; /* Cancel the increment at end of loop */
continue;
}
}
}
} else {
/* Normal character */
CHECK_ISOLATEDSURROGATE;
}
dst += Tcl_UniCharToUtf(ch, dst);
}
}
/* Check if an high surrogate left over */
if (*statePtr) {
assert(!(flags & ENCODING_UTF)); /* CESU-8, Not UTF-8 */
if (!(flags & TCL_ENCODING_END)) {
/* More data coming */
} else {
/* No more data coming */
if (PROFILE_STRICT(profile)) {
result = (flags & ENCODING_INPUT)
? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
} else {
if (PROFILE_REPLACE(profile)) {
ch = UNICODE_REPLACE_CHAR;
} else {
ch = (Tcl_UniChar) (ptrdiff_t) *statePtr;
}
if (dst < dstEnd) {
dst += Tcl_UniCharToUtf(ch, dst);
++numChars;
} else {
/* No room in destination */
result = TCL_CONVERT_NOSPACE;
}
}
}
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
|
| ︙ | ︙ | |||
2619 2620 2621 2622 2623 2624 2625 | * None. * *------------------------------------------------------------------------- */ static int Utf32ToUtfProc( | | | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
Utf32ToUtfProc(
void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
|
| ︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 |
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (flags & TCL_ENCODING_LE) {
| | > | > | 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 |
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (flags & TCL_ENCODING_LE) {
ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16
| (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
} else {
ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16
| (src[2] & 0xFF) << 8 | (src[3] & 0xFF);
}
if ((unsigned)ch > 0x10FFFF) {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
break;
}
ch = UNICODE_REPLACE_CHAR;
|
| ︙ | ︙ | |||
2748 2749 2750 2751 2752 2753 2754 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf32Proc( | | | 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUtf32Proc(
void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
|
| ︙ | ︙ | |||
2799 2800 2801 2802 2803 2804 2805 |
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
| | | 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 |
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
len = TclUtfToUniChar(src, &ch);
if (SURROGATE(ch)) {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
|
| ︙ | ︙ | |||
2847 2848 2849 2850 2851 2852 2853 | * None. * *------------------------------------------------------------------------- */ static int Utf16ToUtfProc( | | | 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
Utf16ToUtfProc(
void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
|
| ︙ | ︙ | |||
2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 |
*/
if ((srcLen % 2) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen--;
}
/*
* If last code point is a high surrogate, we cannot handle that yet,
* unless we are at the end.
*/
if (!(flags & TCL_ENCODING_END) && (srcLen >= 2) &&
((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) {
result = TCL_CONVERT_MULTIBYTE;
srcLen-= 2;
}
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; src += 2, numChars++) {
| > > | | > > > > > > > > > > > | | | | < | > | | | | < < | | | > | < < < | > > | > | | > > > | > > | | | | < | > | > > > | | > > > | < | | | < < < | < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | > | | > > > > > > > | | > | | | > | < | | | | | | | | | | | | | > > > > | 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 |
*/
if ((srcLen % 2) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen--;
}
#if 0
/*
* If last code point is a high surrogate, we cannot handle that yet,
* unless we are at the end.
*/
if (!(flags & TCL_ENCODING_END) && (srcLen >= 2) &&
((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) {
result = TCL_CONVERT_MULTIBYTE;
srcLen-= 2;
}
#endif
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; src += 2, numChars++) {
if (dst > dstEnd && !HIGH_SURROGATE(ch)) {
result = TCL_CONVERT_NOSPACE;
break;
}
unsigned short prev = ch;
if (flags & TCL_ENCODING_LE) {
ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
} else {
ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF);
}
if (HIGH_SURROGATE(prev)) {
if (LOW_SURROGATE(ch)) {
/*
* High surrogate was followed by a low surrogate.
* Tcl_UniCharToUtf would have stashed away the state in dst.
* Call it again to combine that state with the low surrogate.
* We also have to compensate the numChars as two UTF-16 units
* have been combined into one character.
*/
dst += Tcl_UniCharToUtf(ch | TCL_COMBINE, dst);
} else {
/* High surrogate was not followed by a low surrogate */
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 */
break;
}
if (PROFILE_REPLACE(flags)) {
/*
* Previous loop wrote a single byte to mark the high surrogate.
* Replace it with the replacement character.
*/
ch = UNICODE_REPLACE_CHAR;
dst--;
numChars++;
dst += Tcl_UniCharToUtf(ch, dst);
} else {
/*
* Bug [10c2c17c32]. If Hi surrogate not followed by Lo
* surrogate, finish 3-byte UTF-8
*/
dst += Tcl_UniCharToUtf(-1, dst);
}
/* Loop around again so destination space and other checks are done */
prev = 0; /* Reset high surrogate tracker */
src -= 2;
}
} else {
/* Previous char was not a high surrogate */
/*
* Special case for 1-byte utf chars for speed. Make sure we work with
* unsigned short-size data. Order checks based on expected frequency.
*/
if ((unsigned)ch - 1 < 0x7F) {
/* ASCII except nul */
*dst++ = (ch & 0xFF);
} else if (!SURROGATE(ch)) {
/* Not ASCII, not surrogate */
dst += Tcl_UniCharToUtf(ch, dst);
} else if (HIGH_SURROGATE(ch)) {
dst += Tcl_UniCharToUtf(ch | TCL_COMBINE, dst);
/* Do not count this just yet. Compensate for numChars++ in loop counter */
numChars--;
} else {
assert(LOW_SURROGATE(ch));
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
break;
}
if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
}
dst += Tcl_UniCharToUtf(ch, dst);
}
}
}
/*
* When the above loop ends, result may have the following values:
* 1. TCL_OK - full source buffer was completely processed.
* src, dst, numChars will hold values up to that point BUT
* there may be a leftover high surrogate we need to deal with.
* 2. TCL_CONVERT_NOSPACE - Ran out of room in the destination buffer.
* Same considerations as (1)
* 3. TCL_CONVERT_SYNTAX - decoding error.
* 4. TCL_CONVERT_MULTIBYTE - the buffer passed in was not fully
* processed, because there was a trailing single byte. However,
* we *may* have processed the requested number of characters already
* in which case the trailing byte does not matter. We still
* *may* still be a leftover high surrogate as in (1) and (2).
*/
switch (result) {
case TCL_CONVERT_MULTIBYTE: /* FALLTHRU */
case TCL_OK: /* FALLTHRU */
case TCL_CONVERT_NOSPACE:
if (HIGH_SURROGATE(ch)) {
if (flags & TCL_ENCODING_END) {
/*
* No more data expected. There will be space for output of
* one character (essentially overwriting the dst area holding
* high surrogate state)
*/
assert((dst-1) <= dstEnd);
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
src -= 2;
dst--;
} else if (PROFILE_REPLACE(flags)) {
dst--;
numChars++;
dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
} else {
/* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */
numChars++;
dst += Tcl_UniCharToUtf(-1, dst);
}
} else {
/* More data is expected. Revert the surrogate state */
src -= 2;
dst--;
/* Note: leave result of TCL_CONVERT_NOSPACE as is */
if (result == TCL_OK) {
result = TCL_CONVERT_MULTIBYTE;
}
}
} else if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) {
/*
* If we had a trailing byte at the end AND this is the last
* fragment AND profile is not "strict", stick FFFD in its place.
* Note in this case we DO need to check for room in dst.
*/
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
} else {
/* PROFILE_REPLACE or PROFILE_TCL8 */
result = TCL_OK;
dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
numChars++;
src++;
}
}
}
break;
case TCL_CONVERT_SYNTAX:
break; /* Nothing to do */
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
|
| ︙ | ︙ | |||
3025 3026 3027 3028 3029 3030 3031 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf16Proc( | | | 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUtf16Proc(
void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
|
| ︙ | ︙ | |||
3076 3077 3078 3079 3080 3081 3082 |
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
| | | | < > > > > > > > > > > < < < < < > | 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 |
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
len = TclUtfToUniChar(src, &ch);
if (SURROGATE(ch)) {
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
}
}
if (ch <= 0xFFFF) {
if (flags & TCL_ENCODING_LE) {
*dst++ = (ch & 0xFF);
*dst++ = (ch >> 8);
} else {
*dst++ = (ch >> 8);
*dst++ = (ch & 0xFF);
}
} else {
if ((dst+2) > dstEnd) {
/* Surrogates need 2 more bytes! Bug [66da4d4228] */
result = TCL_CONVERT_NOSPACE;
break;
}
if (flags & TCL_ENCODING_LE) {
*dst++ = (((ch - 0x10000) >> 10) & 0xFF);
*dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8;
*dst++ = (ch & 0xFF);
*dst++ = ((ch >> 8) & 0x3) | 0xDC;
} else {
*dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8;
*dst++ = (((ch - 0x10000) >> 10) & 0xFF);
*dst++ = ((ch >> 8) & 0x3) | 0xDC;
*dst++ = (ch & 0xFF);
}
}
src += len;
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
|
| ︙ | ︙ | |||
3133 3134 3135 3136 3137 3138 3139 | * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2Proc( | | | 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUcs2Proc(
void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
|
| ︙ | ︙ | |||
3237 3238 3239 3240 3241 3242 3243 | * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc( | | | 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
TableToUtfProc(
void *clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
|
| ︙ | ︙ | |||
3323 3324 3325 3326 3327 3328 3329 |
src--;
}
if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
} else {
char chbuf[2];
chbuf[0] = byte; chbuf[1] = 0;
| | | 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 |
src--;
}
if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
} else {
char chbuf[2];
chbuf[0] = byte; chbuf[1] = 0;
TclUtfToUniChar(chbuf, &ch);
}
}
/*
* Special case for 1-byte Utf chars for speed.
*/
|
| ︙ | ︙ | |||
3365 3366 3367 3368 3369 3370 3371 | * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc( | | | 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
TableFromUtfProc(
void *clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
|
| ︙ | ︙ | |||
3657 3658 3659 3660 3661 3662 3663 | * Memory freed. * *--------------------------------------------------------------------------- */ static void TableFreeProc( | | | 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 |
* Memory freed.
*
*---------------------------------------------------------------------------
*/
static void
TableFreeProc(
void *clientData) /* TableEncodingData that specifies
* encoding. */
{
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
/*
* Make sure we aren't freeing twice on shutdown. [Bug 219314]
*/
|
| ︙ | ︙ | |||
3692 3693 3694 3695 3696 3697 3698 | * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc( | | | 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
EscapeToUtfProc(
void *clientData, /* EscapeEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
|
| ︙ | ︙ | |||
3905 3906 3907 3908 3909 3910 3911 | * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc( | | | 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
EscapeFromUtfProc(
void *clientData, /* EscapeEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
|
| ︙ | ︙ | |||
3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 |
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
word = tableFromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
int oldState;
const EscapeSubTable *subTablePtr;
oldState = state;
| > > > > > > > > > | 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 |
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
if (ch > 0xFFFF) {
/* Bug 201c7a3aa6 crash - tables are 256x256 (64K) */
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
break;
}
/* Will be encoded as encoding specific replacement below */
ch = UNICODE_REPLACE_CHAR;
}
word = tableFromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
int oldState;
const EscapeSubTable *subTablePtr;
oldState = state;
|
| ︙ | ︙ | |||
4116 4117 4118 4119 4120 4121 4122 | * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( | | | 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 |
* Memory is freed.
*
*---------------------------------------------------------------------------
*/
static void
EscapeFreeProc(
void *clientData) /* EscapeEncodingData that specifies
* encoding. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
EscapeSubTable *subTablePtr;
int i;
if (dataPtr == NULL) {
|
| ︙ | ︙ | |||
4273 4274 4275 4276 4277 4278 4279 |
TclNewLiteralStringObj(encodingObj, "encoding");
TclNewObj(searchPathObj);
Tcl_IncrRefCount(encodingObj);
Tcl_IncrRefCount(searchPathObj);
libPathObj = TclGetProcessGlobalValue(&libraryPath);
Tcl_IncrRefCount(libPathObj);
| | | | 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 |
TclNewLiteralStringObj(encodingObj, "encoding");
TclNewObj(searchPathObj);
Tcl_IncrRefCount(encodingObj);
Tcl_IncrRefCount(searchPathObj);
libPathObj = TclGetProcessGlobalValue(&libraryPath);
Tcl_IncrRefCount(libPathObj);
TclListObjLength(NULL, libPathObj, &numDirs);
for (i = 0; i < numDirs; i++) {
Tcl_Obj *directoryObj, *pathObj;
Tcl_StatBuf stat;
Tcl_ListObjIndex(NULL, libPathObj, i, &directoryObj);
pathObj = Tcl_FSJoinToPath(directoryObj, 1, &encodingObj);
Tcl_IncrRefCount(pathObj);
if ((0 == Tcl_FSStat(pathObj, &stat)) && S_ISDIR(stat.st_mode)) {
Tcl_ListObjAppendElement(NULL, searchPathObj, pathObj);
}
Tcl_DecrRefCount(pathObj);
}
Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
bytes = TclGetStringFromObj(searchPathObj, &numBytes);
*lengthPtr = numBytes;
*valuePtr = (char *)Tcl_Alloc(numBytes + 1);
memcpy(*valuePtr, bytes, numBytes + 1);
Tcl_DecrRefCount(searchPathObj);
}
|
| ︙ | ︙ | |||
4321 4322 4323 4324 4325 4326 4327 |
*
*------------------------------------------------------------------------
*/
int
TclEncodingProfileNameToId(
Tcl_Interp *interp, /* For error messages. May be NULL */
const char *profileName, /* Name of profile */
| | < < | | | | | 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 |
*
*------------------------------------------------------------------------
*/
int
TclEncodingProfileNameToId(
Tcl_Interp *interp, /* For error messages. May be NULL */
const char *profileName, /* Name of profile */
int *profilePtr) /* Output */
{
size_t i;
size_t numProfiles = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);
for (i = 0; i < numProfiles; ++i) {
if (!strcmp(profileName, encodingProfiles[i].name)) {
*profilePtr = encodingProfiles[i].value;
return TCL_OK;
}
}
if (interp) {
/* This code assumes at least two profiles :-) */
Tcl_Obj *errorObj = Tcl_ObjPrintf("bad profile name \"%s\": must be",
profileName);
for (i = 0; i < (numProfiles - 1); ++i) {
Tcl_AppendStringsToObj(
errorObj, " ", encodingProfiles[i].name, ",", (char *)NULL);
}
Tcl_AppendStringsToObj(
errorObj, " or ", encodingProfiles[numProfiles-1].name, (char *)NULL);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(
interp, "TCL", "ENCODING", "PROFILE", profileName, (char *)NULL);
}
return TCL_ERROR;
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4380 4381 4382 4383 4384 4385 4386 |
for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) {
if (profileValue == encodingProfiles[i].value) {
return encodingProfiles[i].name;
}
}
if (interp) {
| | < < | < | | > | | | | 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 |
for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) {
if (profileValue == encodingProfiles[i].value) {
return encodingProfiles[i].name;
}
}
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Internal error. Bad profile id \"%d\".", profileValue));
Tcl_SetErrorCode(
interp, "TCL", "ENCODING", "PROFILEID", (char *)NULL);
}
return NULL;
}
/*
*------------------------------------------------------------------------
*
* TclGetEncodingProfiles --
*
* Get the list of supported encoding profiles.
*
* Results:
* None.
*
* Side effects:
* The list of profile names is stored in the interpreter result.
*
*------------------------------------------------------------------------
*/
void
TclGetEncodingProfiles(
Tcl_Interp *interp)
{
size_t i, n;
Tcl_Obj *objPtr;
n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);
objPtr = Tcl_NewListObj(n, NULL);
for (i = 0; i < n; ++i) {
Tcl_ListObjAppendElement(interp, objPtr,
Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE));
}
Tcl_SetObjResult(interp, objPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #include "tclInt.h" #include "tclCompile.h" /* * Declarations for functions local to this file: */ | > > > > > > > > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | #include "tclInt.h" #include "tclCompile.h" /* * Declarations for functions local to this file: */ static Tcl_Command InitEnsembleFromOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ReadOneEnsembleOption(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *optionObj); static int ReadAllEnsembleOptions(Tcl_Interp *interp, Tcl_Command token); static int SetEnsembleConfigOptions(Tcl_Interp *interp, Tcl_Command token, int objc, Tcl_Obj *const objv[]); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
| | | | | | > | | | | | | | | < < < < < < < < < < < < | 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 |
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define ECRSetInternalRep(objPtr, ecRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (ecRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \
} while (0)
#define ECRGetInternalRep(objPtr, ecRepPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \
(ecRepPtr) = irPtr ? (EnsembleCmdRep *) \
irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The internal rep for caching ensemble subcommand lookups and spelling
* corrections.
*/
typedef struct {
Tcl_Size epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Command *token; /* Reference to the command for which this
* structure is a cache of the resolution. */
Tcl_Obj *fix; /* Corrected spelling, if needed. */
Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash
* table. */
} EnsembleCmdRep;
/*
*----------------------------------------------------------------------
*
* TclNamespaceEnsembleCmd --
*
* Invoked to implement the "namespace ensemble" command that creates and
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
int
TclNamespaceEnsembleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < | < | < < < < | | < | | < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
int
TclNamespaceEnsembleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
Tcl_Command token; /* The ensemble command. */
enum EnsSubcmds index;
if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tried to manipulate ensemble of deleted namespace",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL);
}
return TCL_ERROR;
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
} else if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
"subcommand", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case ENS_CREATE:
/*
* Check that we've got option-value pairs... [Bug 1558654]
*/
if (objc & 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
return TCL_ERROR;
}
token = InitEnsembleFromOptions(interp, objc - 2, objv + 2);
if (token == NULL) {
return TCL_ERROR;
}
/*
* Tricky! Must ensure that the result is not shared (command delete
* traces could have corrupted the pristine object that we started
* with). [Snit test rename-1.5]
*/
Tcl_ResetResult(interp);
Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
return TCL_OK;
case ENS_EXISTS:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
}
token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
if (token == NULL) {
return TCL_ERROR;
}
if (objc == 4) {
| < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
if (token == NULL) {
return TCL_ERROR;
}
if (objc == 4) {
return ReadOneEnsembleOption(interp, token, objv[3]);
} else if (objc == 3) {
return ReadAllEnsembleOptions(interp, token);
} else {
return SetEnsembleConfigOptions(interp, token, objc - 3, objv + 3);
}
default:
Tcl_Panic("unexpected ensemble command");
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InitEnsembleFromOptions --
*
* Core of implementation of "namespace ensemble create".
*
* Results:
* Returns created ensemble's command token if successful, and NULL if
* anything goes wrong.
*
* Side effects:
* Creates the ensemble for the namespace if one did not previously
* exist.
*
* Note:
* Can't use SetEnsembleConfigOptions() here. Different (but overlapping)
* options are supported.
*
*----------------------------------------------------------------------
*/
static Tcl_Command
InitEnsembleFromOptions(
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
Namespace *cxtPtr = nsPtr->parentPtr;
Namespace *altFoundNsPtr, *actualCxtPtr;
const char *name = nsPtr->name;
Tcl_Size len;
int allocatedMapFlag = 0;
enum EnsCreateOpts index;
Tcl_Command token; /* The created ensemble command. */
Namespace *foundNsPtr;
const char *simpleName;
/*
* Defaults
*/
Tcl_Obj *subcmdObj = NULL;
Tcl_Obj *mapObj = NULL;
int permitPrefix = 1;
Tcl_Obj *unknownObj = NULL;
Tcl_Obj *paramObj = NULL;
/*
* Parse the option list, applying type checks as we go. Note that we are
* not incrementing any reference counts in the objects at this stage, so
* the presence of an option multiple times won't cause any memory leaks.
*/
for (; objc>1 ; objc-=2,objv+=2) {
if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions,
"option", 0, &index) != TCL_OK) {
goto error;
}
switch (index) {
case CRT_CMD:
name = TclGetString(objv[1]);
cxtPtr = nsPtr;
continue;
case CRT_SUBCMDS:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
goto error;
}
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CRT_PARAM:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
goto error;
}
paramObj = (len > 0 ? objv[1] : NULL);
continue;
case CRT_MAP: {
Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, *listObj;
Tcl_DictSearch search;
int done;
/*
* Verify that the map is sensible.
*/
if (Tcl_DictObjFirst(interp, objv[1], &search,
&subcmdWordsObj, &listObj, &done) != TCL_OK) {
goto error;
} else if (done) {
mapObj = NULL;
continue;
}
do {
Tcl_Obj **listv;
const char *cmd;
if (TclListObjGetElements(interp, listObj, &len,
&listv) != TCL_OK) {
goto mapError;
}
if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
"must be non-empty lists", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
"EMPTY_TARGET", (char *)NULL);
goto mapError;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_NewListObj(len, listv);
Tcl_Obj *newCmd = TclNewNamespaceObj(
(Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList);
}
Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, &done);
} while (!done);
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
mapObj = (patchedDict ? patchedDict : objv[1]);
if (patchedDict) {
allocatedMapFlag = 1;
}
continue;
mapError:
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto error;
}
case CRT_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
&permitPrefix) != TCL_OK) {
goto error;
}
continue;
case CRT_UNKNOWN:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
goto error;
}
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
}
}
TclGetNamespaceForQualName(interp, name, cxtPtr,
TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr,
&actualCxtPtr, &simpleName);
/*
* Create the ensemble. Note that this might delete another ensemble
* linked to the same namespace, so we must be careful. However, we
* should be OK because we only link the namespace into the list once
* we've created it (and after any deletions have occurred.)
*/
token = TclCreateEnsembleInNs(interp, simpleName,
(Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
(permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
Tcl_SetEnsembleParameterList(interp, token, paramObj);
return token;
error:
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ReadOneEnsembleOption --
*
* Core of implementation of "namespace ensemble configure" with just a
* single option name.
*
* Results:
* Tcl result code. Modifies the interpreter result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ReadOneEnsembleOption(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble to read from. */
Tcl_Obj *optionObj) /* The name of the option to read. */
{
Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
enum EnsConfigOpts index;
if (Tcl_GetIndexFromObj(interp, optionObj, ensembleConfigOptions,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case CONF_SUBCMDS:
Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case CONF_PARAM:
Tcl_GetEnsembleParameterList(NULL, token, &resultObj);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case CONF_MAP:
Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case CONF_NAMESPACE: {
Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
Tcl_SetObjResult(interp, TclNewNamespaceObj(namespacePtr));
break;
}
case CONF_PREFIX: {
int flags = 0; /* silence gcc 4 warning */
Tcl_GetEnsembleFlags(NULL, token, &flags);
Tcl_SetObjResult(interp,
Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
break;
}
case CONF_UNKNOWN:
Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ReadAllEnsembleOptions --
*
* Core of implementation of "namespace ensemble configure" without
* option names.
*
* Results:
* Tcl result code. Modifies the interpreter result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ReadAllEnsembleOptions(
Tcl_Interp *interp,
Tcl_Command token) /* The ensemble to read from. */
{
Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
int flags = 0; /* silence gcc 4 warning */
Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
TclNewObj(resultObj);
/* -map option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP],
TCL_AUTO_LENGTH));
Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
Tcl_ListObjAppendElement(NULL, resultObj,
(tmpObj != NULL) ? tmpObj : Tcl_NewObj());
/* -namespace option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
TCL_AUTO_LENGTH));
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
Tcl_ListObjAppendElement(NULL, resultObj, TclNewNamespaceObj(namespacePtr));
/* -parameters option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM],
TCL_AUTO_LENGTH));
Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
Tcl_ListObjAppendElement(NULL, resultObj,
(tmpObj != NULL) ? tmpObj : Tcl_NewObj());
/* -prefix option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX],
TCL_AUTO_LENGTH));
Tcl_GetEnsembleFlags(NULL, token, &flags);
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
/* -subcommands option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],
TCL_AUTO_LENGTH));
Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
Tcl_ListObjAppendElement(NULL, resultObj,
(tmpObj != NULL) ? tmpObj : Tcl_NewObj());
/* -unknown option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],
TCL_AUTO_LENGTH));
Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
Tcl_ListObjAppendElement(NULL, resultObj,
(tmpObj != NULL) ? tmpObj : Tcl_NewObj());
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetEnsembleConfigOptions --
*
* Core of implementation of "namespace ensemble configure" with even
* number of arguments (where there is at least one pair).
*
* Results:
* Tcl result code. Modifies the interpreter result.
*
* Side effects:
* Modifies the ensemble's configuration.
*
*----------------------------------------------------------------------
*/
static int
SetEnsembleConfigOptions(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble to configure. */
int objc, /* The count of option-related arguments. */
Tcl_Obj *const objv[]) /* Option-related arguments. */
{
Tcl_Size len;
int allocatedMapFlag = 0;
Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
*unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
Tcl_Obj *listObj;
Tcl_DictSearch search;
int permitPrefix, flags = 0; /* silence gcc 4 warning */
enum EnsConfigOpts index;
int done;
Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
Tcl_GetEnsembleParameterList(NULL, token, ¶mObj);
Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
Tcl_GetEnsembleFlags(NULL, token, &flags);
permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
/*
* Parse the option list, applying type checks as we go. Note that
* we are not incrementing any reference counts in the objects at
* this stage, so the presence of an option multiple times won't
* cause any memory leaks.
*/
for (; objc>0 ; objc-=2,objv+=2) {
if (Tcl_GetIndexFromObj(interp, objv[0], ensembleConfigOptions,
"option", 0, &index) != TCL_OK) {
goto freeMapAndError;
}
switch (index) {
case CONF_SUBCMDS:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CONF_PARAM:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
paramObj = (len > 0 ? objv[1] : NULL);
continue;
case CONF_MAP: {
Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
const char *cmd;
/*
* Verify that the map is sensible.
*/
if (Tcl_DictObjFirst(interp, objv[1], &search,
&subcmdWordsObj, &listObj, &done) != TCL_OK) {
goto freeMapAndError;
} else if (done) {
mapObj = NULL;
continue;
}
do {
if (TclListObjLength(interp, listObj, &len) != TCL_OK) {
goto finishSearchAndError;
}
if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
"must be non-empty lists", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
"EMPTY_TARGET", (char *)NULL);
goto finishSearchAndError;
}
if (TclListObjGetElements(interp, listObj, &len,
&listv) != TCL_OK) {
goto finishSearchAndError;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
Tcl_Obj *newCmd = TclNewNamespaceObj(
(Tcl_Namespace*) nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList);
}
Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, &done);
} while (!done);
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
mapObj = (patchedDict ? patchedDict : objv[1]);
if (patchedDict) {
allocatedMapFlag = 1;
}
continue;
finishSearchAndError:
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
case CONF_NAMESPACE:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"option -namespace is read-only", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
(char *)NULL);
goto freeMapAndError;
case CONF_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
&permitPrefix) != TCL_OK) {
goto freeMapAndError;
}
continue;
case CONF_UNKNOWN:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
}
}
/*
* Update the namespace now that we've finished the parsing stage.
*/
flags = (permitPrefix ? flags | TCL_ENSEMBLE_PREFIX
: flags & ~TCL_ENSEMBLE_PREFIX);
Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
Tcl_SetEnsembleParameterList(interp, token, paramObj);
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
Tcl_SetEnsembleFlags(interp, token, flags);
return TCL_OK;
freeMapAndError:
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclCreateEnsembleInNs --
*
* Like Tcl_CreateEnsemble, but additionally accepts as an argument the
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 |
Tcl_Interp *interp,
const char *name, /* Simple name of command to create (no
* namespace components). */
Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command
* in. */
Tcl_Namespace *ensembleNsPtr,
/* Name of the namespace for the ensemble. */
| | > | | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 |
Tcl_Interp *interp,
const char *name, /* Simple name of command to create (no
* namespace components). */
Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command
* in. */
Tcl_Namespace *ensembleNsPtr,
/* Name of the namespace for the ensemble. */
int flags) /* Whether we need exact matching and whether
* we bytecode-compile the ensemble's uses. */
{
Namespace *nsPtr = (Namespace *) ensembleNsPtr;
EnsembleConfig *ensemblePtr;
Tcl_Command token;
ensemblePtr = (EnsembleConfig *) Tcl_Alloc(sizeof(EnsembleConfig));
token = TclNRCreateCommandInNs(interp, name,
(Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
if (token == NULL) {
Tcl_Free(ensemblePtr);
return NULL;
}
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 | * Value * * The token for the command created. * * Effect * The ensemble is created and marked for compilation. * | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
* Value
*
* The token for the command created.
*
* Effect
* The ensemble is created and marked for compilation.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_CreateEnsemble(
Tcl_Interp *interp,
const char *name, /* The ensemble name. */
Tcl_Namespace *namespacePtr,/* Context namespace. */
int flags) /* Whether we need exact matching and whether
* we bytecode-compile the ensemble's uses. */
{
Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr,
*actualNsPtr;
const char * simpleName;
if (nsPtr == NULL) {
nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
&foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
return TclCreateEnsembleInNs(interp, simpleName,
(Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}
/*
*----------------------------------------------------------------------
*
* GetEnsembleFromCommand --
*
* Standard check to see if a command is an ensemble.
*
* Results:
* The ensemble implementation if the command is an ensemble. NULL if it
* isn't.
*
* Side effects:
* Reports an error in the interpreter (if non-NULL) if the command is
* not an ensemble.
*
*----------------------------------------------------------------------
*/
static inline EnsembleConfig *
GetEnsembleFromCommand(
Tcl_Interp *interp, /* Where to report an error. May be NULL. */
Tcl_Command token) /* What to check for ensemble-ness. */
{
Command *cmdPtr = (Command *) token;
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp,
"TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL);
}
return NULL;
}
return (EnsembleConfig *) cmdPtr->objClientData;
}
/*
*----------------------------------------------------------------------
*
* BumpEpochIfNecessary --
*
* Increments the compilation epoch if the (ensemble) command is one where
* changes would be seen by the compiler in some cases.
*
* Results:
* None.
*
* Side effects:
* May trigger later bytecode recompilations.
*
*----------------------------------------------------------------------
*/
static inline void
BumpEpochIfNecessary(
Tcl_Interp *interp,
Tcl_Command token) /* The ensemble command to check. */
{
/*
* Special hack to make compiling of [info exists] work when the
* dictionary is modified.
*/
if (((Command *) token)->compileProc != NULL) {
((Interp *) interp)->compileEpoch++;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleSubcommandList --
*
* Set the subcommand list for a particular ensemble.
|
| ︙ | ︙ | |||
785 786 787 788 789 790 791 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleSubcommandList(
Tcl_Interp *interp,
| | < | < < | < | < | < < < < < < < < < | 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 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleSubcommandList(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to write to. */
Tcl_Obj *subcmdList)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
Tcl_Obj *oldList;
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
if (subcmdList != NULL) {
Tcl_Size length;
if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
subcmdList = NULL;
}
}
oldList = ensemblePtr->subcmdList;
ensemblePtr->subcmdList = subcmdList;
if (subcmdList != NULL) {
Tcl_IncrRefCount(subcmdList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
}
/*
* Trigger an eventual recomputation of the ensemble command set. Note
* that this is slightly tricky, as it means that we are not actually
* counting the number of namespace export actions, but it is the simplest
* way to go!
*/
ensemblePtr->nsPtr->exportLookupEpoch++;
BumpEpochIfNecessary(interp, token);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleParameterList --
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleParameterList(
Tcl_Interp *interp,
| | < | < < | < | < | < < < < < < < < < | 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 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleParameterList(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to write to. */
Tcl_Obj *paramList)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
Tcl_Obj *oldList;
Tcl_Size length;
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
if (paramList == NULL) {
length = 0;
} else {
if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
paramList = NULL;
}
}
oldList = ensemblePtr->parameterList;
ensemblePtr->parameterList = paramList;
if (paramList != NULL) {
Tcl_IncrRefCount(paramList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
}
ensemblePtr->numParameters = length;
/*
* Trigger an eventual recomputation of the ensemble command set. Note
* that this is slightly tricky, as it means that we are not actually
* counting the number of namespace export actions, but it is the simplest
* way to go!
*/
ensemblePtr->nsPtr->exportLookupEpoch++;
BumpEpochIfNecessary(interp, token);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleMappingDict --
|
| ︙ | ︙ | |||
937 938 939 940 941 942 943 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleMappingDict(
Tcl_Interp *interp,
| | < | < < | < | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleMappingDict(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to write to. */
Tcl_Obj *mapDict)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
Tcl_Obj *oldDict;
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
if (mapDict != NULL) {
Tcl_Size size;
int done;
Tcl_DictSearch search;
Tcl_Obj *valuePtr;
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
bytes = TclGetString(cmdObjPtr);
if (bytes[0] != ':' || bytes[1] != ':') {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble target is not a fully-qualified command",
| | | < | < < < < < < < < < | 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 |
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
bytes = TclGetString(cmdObjPtr);
if (bytes[0] != ':' || bytes[1] != ':') {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble target is not a fully-qualified command",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
"UNQUALIFIED_TARGET", (char *)NULL);
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
}
if (size < 1) {
mapDict = NULL;
}
}
oldDict = ensemblePtr->subcommandDict;
ensemblePtr->subcommandDict = mapDict;
if (mapDict != NULL) {
Tcl_IncrRefCount(mapDict);
}
if (oldDict != NULL) {
TclDecrRefCount(oldDict);
}
/*
* Trigger an eventual recomputation of the ensemble command set. Note
* that this is slightly tricky, as it means that we are not actually
* counting the number of namespace export actions, but it is the simplest
* way to go!
*/
ensemblePtr->nsPtr->exportLookupEpoch++;
BumpEpochIfNecessary(interp, token);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleUnknownHandler --
|
| ︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleUnknownHandler(
Tcl_Interp *interp,
| | < | < < | < | < | 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 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleUnknownHandler(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to write to. */
Tcl_Obj *unknownList)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
Tcl_Obj *oldList;
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
if (unknownList != NULL) {
Tcl_Size length;
if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
unknownList = NULL;
}
}
oldList = ensemblePtr->unknownHandler;
ensemblePtr->unknownHandler = unknownList;
if (unknownList != NULL) {
Tcl_IncrRefCount(unknownList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
|
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleFlags(
Tcl_Interp *interp,
| | < | | < < | < < < < | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleFlags(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to write to. */
int flags)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
int changedFlags = flags ^ ensemblePtr->flags;
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
/*
* This API refuses to set the ENSEMBLE_DEAD flag...
*/
ensemblePtr->flags &= ENSEMBLE_DEAD;
ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD;
|
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 |
/*
* If the ENSEMBLE_COMPILE flag status was changed, install or remove the
* compiler function and bump the interpreter's compilation epoch so that
* bytecode gets regenerated.
*/
| | < | < < < | < | < | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 |
/*
* If the ENSEMBLE_COMPILE flag status was changed, install or remove the
* compiler function and bump the interpreter's compilation epoch so that
* bytecode gets regenerated.
*/
if (changedFlags & ENSEMBLE_COMPILE) {
((Command*) ensemblePtr->token)->compileProc =
((flags & ENSEMBLE_COMPILE) ? TclCompileEnsemble : NULL);
((Interp *) interp)->compileEpoch++;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleSubcommandList(
Tcl_Interp *interp,
| | < | < | < < < < < < | 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleSubcommandList(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to read from. */
Tcl_Obj **subcmdListPtr)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1222 1223 1224 1225 1226 1227 1228 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleParameterList(
Tcl_Interp *interp,
| | < | < | < < < < < < | 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleParameterList(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to read from. */
Tcl_Obj **paramListPtr)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
*paramListPtr = ensemblePtr->parameterList;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleMappingDict(
Tcl_Interp *interp,
| | < | < | < < < < < < | 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleMappingDict(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to read from. */
Tcl_Obj **mapDictPtr)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleUnknownHandler(
Tcl_Interp *interp,
| | < | < | < < < < < < | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleUnknownHandler(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to read from. */
Tcl_Obj **unknownListPtr)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1346 1347 1348 1349 1350 1351 1352 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleFlags(
Tcl_Interp *interp,
| | < | < | < < < < < < | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleFlags(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to read from. */
int *flagsPtr)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleNamespace(
Tcl_Interp *interp,
| | < | < | < < < < < < | 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleNamespace(
Tcl_Interp *interp,
Tcl_Command token, /* The ensemble command to read from. */
Tcl_Namespace **namespacePtrPtr)
{
EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token);
if (ensemblePtr == NULL) {
return TCL_ERROR;
}
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
Tcl_Interp *interp, /* Where to do the lookup, and where to write
* the errors if TCL_LEAVE_ERR_MSG is set in
* the flags. */
Tcl_Obj *cmdNameObj, /* Name of command to look up. */
int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
* are probably not useful. */
{
| | < | | | | | | | | | 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
Tcl_Interp *interp, /* Where to do the lookup, and where to write
* the errors if TCL_LEAVE_ERR_MSG is set in
* the flags. */
Tcl_Obj *cmdNameObj, /* Name of command to look up. */
int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
* are probably not useful. */
{
Tcl_Command token;
token = Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
if (token == NULL) {
return NULL;
}
if (((Command *) token)->objProc != TclEnsembleImplementationCmd) {
/*
* Reuse existing infrastructure for following import link chains
* rather than duplicating it.
*/
token = TclGetOriginalCommand(token);
if (token == NULL ||
((Command *) token)->objProc != TclEnsembleImplementationCmd) {
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not an ensemble command",
TclGetString(cmdNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
TclGetString(cmdNameObj), (char *)NULL);
}
return NULL;
}
}
return token;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsEnsemble --
*
|
| ︙ | ︙ | |||
1486 1487 1488 1489 1490 1491 1492 | * None * *---------------------------------------------------------------------- */ int Tcl_IsEnsemble( | | | 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
* None
*
*----------------------------------------------------------------------
*/
int
Tcl_IsEnsemble(
Tcl_Command token) /* The command to check. */
{
Command *cmdPtr = (Command *) token;
if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
return 1;
}
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
*
* The 'name' parameter may be a single command name or a list if
* creating an ensemble subcommand (see the binary implementation).
*
* Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
* top-level ensemble commands.
*
* Results:
* Handle for the new ensemble, or NULL on failure.
*
* Side effects:
* May advance the bytecode compilation epoch.
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclMakeEnsemble(
Tcl_Interp *interp,
| > > > > > | | | | | | 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 |
*
* The 'name' parameter may be a single command name or a list if
* creating an ensemble subcommand (see the binary implementation).
*
* Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
* top-level ensemble commands.
*
* This code is not safe to run in Safe interpreter after user code has
* executed. That's OK right now because it's just used to set up Tcl,
* but it means we mustn't expose it at all, not even to Tk (until we can
* hide commands in namespaces directly).
*
* Results:
* Handle for the new ensemble, or NULL on failure.
*
* Side effects:
* May advance the bytecode compilation epoch.
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclMakeEnsemble(
Tcl_Interp *interp,
const char *name, /* The ensemble name (as explained above) */
const EnsembleImplMap map[])/* The subcommands to create */
{
Tcl_Command ensemble;
Tcl_Namespace *ns;
Tcl_DString buf, hiddenBuf;
const char **nameParts = NULL;
const char *cmdName = NULL;
Tcl_Size i, nameCount = 0;
int ensembleFlags = 0, hiddenLen;
/*
* Construct the path for the ensemble namespace and create it.
*/
Tcl_DStringInit(&buf);
Tcl_DStringInit(&hiddenBuf);
TclDStringAppendLiteral(&hiddenBuf, "tcl:");
Tcl_DStringAppend(&hiddenBuf, name, TCL_AUTO_LENGTH);
TclDStringAppendLiteral(&hiddenBuf, ":");
hiddenLen = Tcl_DStringLength(&hiddenBuf);
if (name[0] == ':' && name[1] == ':') {
/*
* An absolute name, so use it directly.
*/
cmdName = name;
Tcl_DStringAppend(&buf, name, TCL_AUTO_LENGTH);
ensembleFlags = TCL_ENSEMBLE_PREFIX;
} else {
/*
* Not an absolute name, so do munging of it. Note that this treats a
* multi-word list differently to a single word.
*/
TclDStringAppendLiteral(&buf, "::tcl");
if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
Tcl_Panic("invalid ensemble name '%s'", name);
}
for (i = 0; i < nameCount; ++i) {
TclDStringAppendLiteral(&buf, "::");
Tcl_DStringAppend(&buf, nameParts[i], TCL_AUTO_LENGTH);
}
}
ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
TCL_CREATE_NS_IF_UNKNOWN);
if (!ns) {
Tcl_Panic("unable to find or create %s namespace!",
|
| ︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 |
ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
/*
* Create the ensemble mapping dictionary and the ensemble command procs.
*/
if (ensemble != NULL) {
| | < | | | > > > < | > | 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 |
ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
/*
* Create the ensemble mapping dictionary and the ensemble command procs.
*/
if (ensemble != NULL) {
Tcl_Obj *mapDict, *toObj;
Command *cmdPtr;
TclDStringAppendLiteral(&buf, "::");
TclNewObj(mapDict);
for (i=0 ; map[i].name != NULL ; i++) {
TclNewStringObj(toObj, Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf));
Tcl_AppendToObj(toObj, map[i].name, TCL_AUTO_LENGTH);
TclDictPut(NULL, mapDict, map[i].name, toObj);
if (map[i].proc || map[i].nreProc) {
/*
* If the command is unsafe, hide it when we're in a safe
* interpreter. The code to do this is really hokey! It also
* doesn't work properly yet; this function is always
* currently called before the safe-interp flag is set so the
* Tcl_IsSafe check fails.
*/
if (map[i].unsafe && Tcl_IsSafe(interp)) {
cmdPtr = (Command *)
Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
map[i].nreProc, map[i].clientData, NULL);
Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
if (Tcl_HideCommand(interp, "___tmp",
Tcl_DStringAppend(&hiddenBuf, map[i].name,
TCL_AUTO_LENGTH))) {
Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
/* don't compile unsafe subcommands in safe interp */
cmdPtr->compileProc = NULL;
} else {
/*
* Not hidden, so just create it. Yay!
*/
cmdPtr = (Command *)
Tcl_NRCreateCommand(interp, TclGetString(toObj),
map[i].proc, map[i].nreProc, map[i].clientData,
NULL);
cmdPtr->compileProc = map[i].compileProc;
}
}
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
}
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
|
| ︙ | ︙ | |||
1698 1699 1700 1701 1702 1703 1704 |
{
return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
clientData, objc, objv);
}
static int
NsEnsembleImplementationCmdNR(
| | | | 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 |
{
return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
clientData, objc, objv);
}
static int
NsEnsembleImplementationCmdNR(
void *clientData, /* The ensemble this is the impl. of. */
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
/* The ensemble itself. */
Tcl_Obj *prefixObj; /* An object containing the prefix words of
* the command that implements the
* subcommand. */
Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
* specified but not yet cached command
* names. */
|
| ︙ | ︙ | |||
1732 1733 1734 1735 1736 1737 1738 |
* No subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
Tcl_DStringInit(&buf);
if (ensemblePtr->parameterList) {
| < | | > | | 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 |
* No subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
Tcl_DStringInit(&buf);
if (ensemblePtr->parameterList) {
TclDStringAppendObj(&buf, ensemblePtr->parameterList);
TclDStringAppendLiteral(&buf, " ");
}
TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
return TCL_ERROR;
}
if (ensemblePtr->nsPtr->flags & NS_DEAD) {
/*
* Don't know how we got here, but make things give up quickly.
*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble activated for deleted namespace",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL);
}
return TCL_ERROR;
}
/*
* If the table of subcommands is valid just lookup up the command there
* and go to dispatch.
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 |
* is an ensembleCmd, just call it.
*/
EnsembleCmdRep *ensembleCmd;
ECRGetInternalRep(subObj, ensembleCmd);
if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
| | | < | < | | 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 |
* is an ensembleCmd, just call it.
*/
EnsembleCmdRep *ensembleCmd;
ECRGetInternalRep(subObj, ensembleCmd);
if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *) ensemblePtr->token) {
prefixObj = (Tcl_Obj *) Tcl_GetHashValue(ensembleCmd->hPtr);
Tcl_IncrRefCount(prefixObj);
if (ensembleCmd->fix) {
TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
}
goto runResultingSubcommand;
}
}
} else {
BuildEnsembleConfig(ensemblePtr);
ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
}
/*
* Look in the hashtable for the named subcommand. This is the fastest
* path if there is no cache in operation.
*/
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
TclGetString(subObj));
if (hPtr != NULL) {
/*
* Cache ensemble in the subcommand object for later.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
} else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
/*
* Could not map. No prefixing. Go to unknown/error handling.
*/
goto unknownOrAmbiguousSubcommand;
} else {
/*
* If the command isn't yet confirmed with the hash as part of building
* the export table, scan the sorted array for matches.
*/
const char *subcmdName; /* Name of the subcommand or unique prefix of
* it (a non-unique prefix produces an error). */
char *fullName = NULL; /* Full name of the subcommand. */
Tcl_Size stringLength, i;
Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries;
Tcl_Obj *fix;
subcmdName = TclGetStringFromObj(subObj, &stringLength);
for (i=0 ; i<tableLength ; i++) {
int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
stringLength);
if (cmp == 0) {
if (fullName != NULL) {
|
| ︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 | fullName); } /* * Record the spelling correction for usage message. */ | | | | 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 |
fullName);
}
/*
* Record the spelling correction for usage message.
*/
fix = Tcl_NewStringObj(fullName, TCL_AUTO_LENGTH);
/*
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
Tcl_IncrRefCount(prefixObj);
runResultingSubcommand:
/*
* Execute the subcommand by populating an array of objects, which might
* not be the same length as the number of arguments to this ensemble
* command, and then handing it to the main command-lookup engine. In
|
| ︙ | ︙ | |||
1897 1898 1899 1900 1901 1902 1903 |
{
Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
Tcl_Size copyObjc, prefixObjc;
| | | 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
{
Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
Tcl_Size copyObjc, prefixObjc;
TclListObjLength(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclListObjCopy(NULL, prefixObj);
} else {
copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
|
| ︙ | ︙ | |||
1931 1932 1933 1934 1935 1936 1937 | } /* * Hand off to the target command. */ TclSkipTailcall(interp); | | | | 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 |
}
/*
* Hand off to the target command.
*/
TclSkipTailcall(interp);
TclListObjGetElements(NULL, copyPtr, ©Objc, ©Objv);
((Interp *) interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
unknownOrAmbiguousSubcommand:
/*
* The named subcommand did not match any exported command. If there is a
* handler registered unknown subcommands, call it, but not more than once
|
| ︙ | ︙ | |||
1964 1965 1966 1967 1968 1969 1970 |
* failure message. The one odd case compared with a standard
* ensemble-like command is where a namespace has no exported commands at
* all...
*/
Tcl_ResetResult(interp);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
| | | > | > | 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 |
* failure message. The one odd case compared with a standard
* ensemble-like command is where a namespace has no exported commands at
* all...
*/
Tcl_ResetResult(interp);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(subObj), (char *)NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown subcommand \"%s\": namespace %s does not"
" export any commands", TclGetString(subObj),
ensemblePtr->nsPtr->fullName));
return TCL_ERROR;
}
errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
TclGetString(subObj));
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0],
TCL_AUTO_LENGTH);
} else {
Tcl_Size i;
for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i],
TCL_AUTO_LENGTH);
Tcl_AppendToObj(errorObj, ", ", 2);
}
Tcl_AppendPrintfToObj(errorObj, "or %s",
ensemblePtr->subcommandArrayPtr[i]);
}
Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2182 2183 2184 2185 2186 2187 2188 |
}
}
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
| | | | 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 |
}
}
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
Tcl_Obj **tmp = (Tcl_Obj **) Tcl_Alloc(3 * sizeof(Tcl_Obj *));
store = (Tcl_Obj **) Tcl_Alloc(size * sizeof(Tcl_Obj *));
memcpy(store, iPtr->ensembleRewrite.sourceObjs,
size * sizeof(Tcl_Obj *));
/*
* Awful casting abuse here! Note that the NULL in the first element
* indicates that the initial objects are a raw array in the second
* element and the rewritten ones are a raw array in the third.
|
| ︙ | ︙ | |||
2207 2208 2209 2210 2211 2212 2213 |
}
store[idx] = fix;
Tcl_IncrRefCount(fix);
TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
}
| > > > > > > > > > > | > | < > | < | | 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 |
}
store[idx] = fix;
Tcl_IncrRefCount(fix);
TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
* TclEnsembleGetRewriteValues --
*
* Get the original arguments to the current command before any rewrite
* rules (from aliases, ensembles, and method forwards) were applied.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *const *
TclEnsembleGetRewriteValues(
Tcl_Interp *interp) /* Current interpreter. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;
if (origObjv[0] == NULL) {
origObjv = (Tcl_Obj *const *) origObjv[2];
}
return origObjv;
}
/*
*----------------------------------------------------------------------
*
* TclFetchEnsembleRoot --
*
* Returns the root of ensemble rewriting, if any.
* If no root exists, returns objv instead.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *const *
TclFetchEnsembleRoot(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
Tcl_Size objc,
Tcl_Size *objcPtr)
{
Tcl_Obj *const *sourceObjs;
Interp *iPtr = (Interp *) interp;
if (iPtr->ensembleRewrite.sourceObjs) {
*objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
- iPtr->ensembleRewrite.numInsertedObjs;
if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) {
sourceObjs = (Tcl_Obj *const *) iPtr->ensembleRewrite.sourceObjs[1];
} else {
sourceObjs = iPtr->ensembleRewrite.sourceObjs;
}
return sourceObjs;
}
*objcPtr = objc;
return objv;
|
| ︙ | ︙ | |||
2286 2287 2288 2289 2290 2291 2292 |
*
* ----------------------------------------------------------------------
*/
static inline int
EnsembleUnknownCallback(
Tcl_Interp *interp,
| | | | | > > | | > | | | 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 |
*
* ----------------------------------------------------------------------
*/
static inline int
EnsembleUnknownCallback(
Tcl_Interp *interp,
EnsembleConfig *ensemblePtr,/* The ensemble structure. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Actual arguments. */
Tcl_Obj **prefixObjPtr) /* Where to write the prefix suggested by the
* unknown callback. Must not be NULL. Only has
* a meaningful value on TCL_OK. */
{
Tcl_Size paramc;
int result;
Tcl_Size i, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
* Create the "unknown" command callback to determine what to do.
*/
unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
TclNewObj(ensObj);
Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
for (i = 1 ; i < objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv);
Tcl_IncrRefCount(unknownCmd);
/*
* Call the "unknown" handler. No attempt to NRE-enable this as deep
* recursion through unknown handlers is perverse. It is always an error
* for an unknown handler to delete its ensemble. Don't do that.
*/
Tcl_Preserve(ensemblePtr);
TclSkipTailcall(interp);
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown subcommand handler deleted its ensemble",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
(char *)NULL);
}
result = TCL_ERROR;
}
Tcl_Release(ensemblePtr);
/*
* On success the result is a list of words that form the command to be
* executed. If the list is empty, the ensemble should have been updated,
* so ask the ensemble engine to reparse the original command.
*/
if (result == TCL_OK) {
*prefixObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(*prefixObjPtr);
TclDecrRefCount(unknownCmd);
Tcl_ResetResult(interp);
/* A non-empty list is the replacement command. */
if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
TclDecrRefCount(*prefixObjPtr);
Tcl_AddErrorInfo(interp, "\n while parsing result of "
"ensemble unknown subcommand handler");
return TCL_ERROR;
}
if (prefixObjc > 0) {
return TCL_OK;
|
| ︙ | ︙ | |||
2370 2371 2372 2373 2374 2375 2376 |
* Convert exceptional result to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
if (result != TCL_ERROR) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | > | > | > | > | | 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 |
* Convert exceptional result to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
if (result != TCL_ERROR) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown subcommand handler returned bad code: ",
TCL_AUTO_LENGTH));
switch (result) {
case TCL_RETURN:
Tcl_AppendToObj(Tcl_GetObjResult(interp), "return",
TCL_AUTO_LENGTH);
break;
case TCL_BREAK:
Tcl_AppendToObj(Tcl_GetObjResult(interp), "break",
TCL_AUTO_LENGTH);
break;
case TCL_CONTINUE:
Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue",
TCL_AUTO_LENGTH);
break;
default:
Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
}
Tcl_AddErrorInfo(interp, "\n result of "
"ensemble unknown subcommand handler: ");
Tcl_AppendObjToErrorInfo(interp, unknownCmd);
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
(char *)NULL);
} else {
Tcl_AddErrorInfo(interp,
"\n (ensemble unknown subcommand handler)");
}
}
TclDecrRefCount(unknownCmd);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2419 2420 2421 2422 2423 2424 2425 | * ensembleCmd. * *---------------------------------------------------------------------- */ static void MakeCachedEnsembleCommand( | | | | | > | | 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 |
* ensembleCmd.
*
*----------------------------------------------------------------------
*/
static void
MakeCachedEnsembleCommand(
Tcl_Obj *objPtr, /* Object to cache in. */
EnsembleConfig *ensemblePtr,/* Ensemble implementation. */
Tcl_HashEntry *hPtr, /* What to cache; what the object maps to. */
Tcl_Obj *fix) /* Spelling correction for later error, or NULL
* if no correction. */
{
EnsembleCmdRep *ensembleCmd;
ECRGetInternalRep(objPtr, ensembleCmd);
if (ensembleCmd) {
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
} else {
/*
* Replace any old internal representation with a new one.
*/
ensembleCmd = (EnsembleCmdRep *) Tcl_Alloc(sizeof(EnsembleCmdRep));
ECRSetInternalRep(objPtr, ensembleCmd);
}
/*
* Populate the internal rep.
*/
|
| ︙ | ︙ | |||
2476 2477 2478 2479 2480 2481 2482 | * Memory is eventually deallocated. * *---------------------------------------------------------------------- */ static void ClearTable( | | | | | | | | | | | | | 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 |
* Memory is eventually deallocated.
*
*----------------------------------------------------------------------
*/
static void
ClearTable(
EnsembleConfig *ensemblePtr)/* Ensemble to clear table of. */
{
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
if (hash->numEntries != 0) {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(prefixObj);
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_Free(ensemblePtr->subcommandArrayPtr);
}
Tcl_DeleteHashTable(hash);
}
static void
DeleteEnsembleConfig(
void *clientData) /* Ensemble to delete. */
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
/* Unlink from the ensemble chain if it not already marked as unlinked. */
if (ensemblePtr->next != ensemblePtr) {
EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
|
| ︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 | * may be an expensive operation. * *---------------------------------------------------------------------- */ static void BuildEnsembleConfig( | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 |
* may be an expensive operation.
*
*----------------------------------------------------------------------
*/
static void
BuildEnsembleConfig(
EnsembleConfig *ensemblePtr)/* Ensemble to set up. */
{
Tcl_HashSearch search; /* Used for scanning the commands in
* the namespace for this ensemble. */
Tcl_Size i, j;
int isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
Tcl_Obj *subList = ensemblePtr->subcmdList;
ClearTable(ensemblePtr);
Tcl_InitHashTable(hash, TCL_STRING_KEYS);
if (subList) {
Tcl_Size subc;
Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
const char *name;
/*
* There is a list of exactly what subcommands go in the table.
* Determine the target for each.
*/
TclListObjGetElements(NULL, subList, &subc, &subv);
if (subList == mapDict) {
/*
* Unusual case where explicit list of subcommands is same value
* as the dict mapping to targets.
*/
for (i = 0; i < subc; i += 2) {
name = TclGetString(subv[i]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
if (!isNew) {
cmdObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(cmdObj);
}
Tcl_SetHashValue(hPtr, subv[i + 1]);
Tcl_IncrRefCount(subv[i + 1]);
name = TclGetString(subv[i + 1]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
if (isNew) {
cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
}
} else {
/*
* Usual case where we can freely act on the list and dict.
*/
for (i = 0; i < subc; i++) {
name = TclGetString(subv[i]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
if (!isNew) {
continue;
}
/*
* Lookup target in the dictionary.
*/
if (mapDict) {
Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
if (target) {
Tcl_SetHashValue(hPtr, target);
Tcl_IncrRefCount(target);
continue;
}
}
/*
* Target was not in the dictionary. Map onto the namespace.
* In this case there is no guarantee that the command is
* actually there. It is the responsibility of the programmer
* (or [::unknown] of course) to provide the procedure.
*/
cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
}
} else if (mapDict) {
/*
* No subcmd list, but there is a mapping dictionary, so use
* the keys of that. Convert the contents of the dictionary into the
* form required for the internal hashtable of the ensemble.
*/
Tcl_DictSearch dictSearch;
Tcl_Obj *keyObj, *valueObj;
int done;
Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
&keyObj, &valueObj, &done);
while (!done) {
const char *name = TclGetString(keyObj);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
Tcl_SetHashValue(hPtr, valueObj);
Tcl_IncrRefCount(valueObj);
Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
}
} else {
/*
* Use the array of patterns and the hash table whose keys are the
* commands exported by the namespace. The corresponding values do not
* matter here. Filter the commands in the namespace against the
* patterns in the export list to find out what commands are actually
* exported. Use an intermediate hash table to make memory management
* easier and to make exact matching much easier.
*
* Suggestion for future enhancement: Compute the unique prefixes and
* place them in the hash too for even faster matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
char *nsCmdName = (char *) /* Name of command in namespace. */
Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
if (Tcl_StringMatch(nsCmdName,
ensemblePtr->nsPtr->exportArrayPtr[i])) {
hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
/*
* Remember, hash entries have a full reference to the
* substituted part of the command (as a list) as their
* content!
*/
if (isNew) {
Tcl_Obj *cmdObj, *cmdPrefixObj;
TclNewObj(cmdObj);
Tcl_AppendStringsToObj(cmdObj,
ensemblePtr->nsPtr->fullName,
(ensemblePtr->nsPtr->parentPtr ? "::" : ""),
nsCmdName, (char *)NULL);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
break;
}
}
|
| ︙ | ︙ | |||
2750 2751 2752 2753 2754 2755 2756 |
* the error message either.
*
* Do this by filling an array with the names: Use the hash keys
* directly to save a copy since any time we change the array we change
* the hash too, and vice versa, and run quicksort over the array.
*/
| | | | 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 |
* the error message either.
*
* Do this by filling an array with the names: Use the hash keys
* directly to save a copy since any time we change the array we change
* the hash too, and vice versa, and run quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr = (char **)
Tcl_Alloc(sizeof(char *) * hash->numEntries);
/*
* Fill the array from both ends as this reduces the likelihood of
* performance problems in qsort(). This makes this code much more opaque,
* but the naive alternatve:
*
* for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
|
| ︙ | ︙ | |||
2775 2776 2777 2778 2779 2780 2781 |
* to have awful runtime behaviour.
*/
i = 0;
j = hash->numEntries;
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
| | > | > > | | | | 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 |
* to have awful runtime behaviour.
*/
i = 0;
j = hash->numEntries;
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
ensemblePtr->subcommandArrayPtr[i++] = (char *)
Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
if (hPtr == NULL) {
break;
}
ensemblePtr->subcommandArrayPtr[--j] = (char *)
Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
}
if (hash->numEntries > 1) {
qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
sizeof(char *), NsEnsembleStringOrder);
}
}
/*
*----------------------------------------------------------------------
*
* NsEnsembleStringOrder --
*
* Helper to for use with qsort() that compares two array entries that
* contain string pointers.
*
* Results:
* -1 if the first string is smaller, 1 if the second string is smaller,
* and 0 if they are equal.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NsEnsembleStringOrder(
const void *strPtr1, /* Points to first array entry */
const void *strPtr2) /* Points to second array entry */
{
return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2871 2872 2873 2874 2875 2876 2877 |
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
EnsembleCmdRep *ensembleCmd;
| | > | 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 |
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
EnsembleCmdRep *ensembleCmd;
EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
Tcl_Alloc(sizeof(EnsembleCmdRep));
ECRGetInternalRep(objPtr, ensembleCmd);
ECRSetInternalRep(copyPtr, ensembleCopy);
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
|
| ︙ | ︙ | |||
2930 2931 2932 2933 2934 2935 2936 |
int ourResult = TCL_ERROR;
Tcl_Size i, len, numBytes;
const char *word;
TclNewObj(replaced);
Tcl_IncrRefCount(replaced);
if (parsePtr->numWords <= depth) {
| | | | 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 |
int ourResult = TCL_ERROR;
Tcl_Size i, len, numBytes;
const char *word;
TclNewObj(replaced);
Tcl_IncrRefCount(replaced);
if (parsePtr->numWords <= depth) {
goto tryCompileToInv;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* Too hard.
*/
goto tryCompileToInv;
}
/*
* This is where we return to if we are parsing multiple nested compiled
* ensembles. [info object] is such a beast.
*/
|
| ︙ | ︙ | |||
2962 2963 2964 2965 2966 2967 2968 |
if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
|| mapObj == NULL) {
/*
* Either not an ensemble or a mapping isn't installed. Crud. Too hard
* to proceed.
*/
| | | | 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 |
if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
|| mapObj == NULL) {
/*
* Either not an ensemble or a mapping isn't installed. Crud. Too hard
* to proceed.
*/
goto tryCompileToInv;
}
/*
* Also refuse to compile anything that uses a formal parameter list for
* now, on the grounds that it is too complex.
*/
if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
|| listObj != NULL) {
/*
* Figuring out how to compile this has become too much. Bail out.
*/
goto tryCompileToInv;
}
/*
* Next, get the flags. We need them on several code paths so that we can
* know whether we're to do prefix matching.
*/
|
| ︙ | ︙ | |||
2998 2999 3000 3001 3002 3003 3004 |
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
Tcl_Size sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
| | | | | | | | | 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 |
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
Tcl_Size sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
goto tryCompileToInv;
}
for (i=0 ; i<len ; i++) {
str = TclGetStringFromObj(elems[i], &sclen);
if ((sclen == numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
*/
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
goto tryCompileToInv;
}
replacement = elems[i];
goto doneMapLookup;
}
/*
* Check to see if we've got a prefix match. A single prefix match
* is fine, and allows us to refine our dictionary lookup, but
* multiple prefix matches is a Bad Thing and will prevent us from
* making progress. Note that we cannot do the lookup immediately
* in the prefix case; might be another entry later in the list
* that causes things to fail.
*/
if ((flags & TCL_ENSEMBLE_PREFIX)
&& strncmp(word, str, numBytes) == 0) {
if (matchObj != NULL) {
goto tryCompileToInv;
}
matchObj = elems[i];
}
}
if (matchObj == NULL) {
goto tryCompileToInv;
}
result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
goto tryCompileToInv;
}
replacement = matchObj;
} else {
Tcl_DictSearch s;
int done, matched;
Tcl_Obj *tmpObj;
|
| ︙ | ︙ | |||
3068 3069 3070 3071 3072 3073 3074 |
/*
* We've not literally got a valid subcommand. But maybe we have a
* prefix. Check if prefix matches are allowed.
*/
if (!(flags & TCL_ENSEMBLE_PREFIX)) {
| | | 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 |
/*
* We've not literally got a valid subcommand. But maybe we have a
* prefix. Check if prefix matches are allowed.
*/
if (!(flags & TCL_ENSEMBLE_PREFIX)) {
goto tryCompileToInv;
}
/*
* Iterate over the keys in the dictionary, checking to see if we're a
* prefix.
*/
|
| ︙ | ︙ | |||
3103 3104 3105 3106 3107 3108 3109 |
/*
* If we have anything other than a single match, we've failed the
* unique prefix check.
*/
if (matched != 1) {
invokeAnyway = 1;
| | | | | | < | 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 |
/*
* If we have anything other than a single match, we've failed the
* unique prefix check.
*/
if (matched != 1) {
invokeAnyway = 1;
goto tryCompileToInv;
}
}
/*
* OK, we definitely map to something. But what?
*
* The command we map to is the first word out of the map element. Note
* that we also reject dealing with multi-element rewrites if we are in a
* safe interpreter, as there is otherwise a (highly gnarly!) way to make
* Tcl crash open to exploit.
*/
doneMapLookup:
Tcl_ListObjAppendElement(NULL, replaced, replacement);
if (TclListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
goto tryCompileToInv;
} else if (len != 1) {
/*
* Note that at this point we know we can't issue any special
* instruction sequence as the mapping isn't one that we support at
* the compiled level.
*/
goto cleanup;
}
targetCmdObj = elems[0];
oldCmdPtr = cmdPtr;
Tcl_IncrRefCount(targetCmdObj);
newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
TclDecrRefCount(targetCmdObj);
if (newCmdPtr == NULL || (Tcl_IsSafe(interp) && !cmdPtr->compileProc)
|| newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
|| newCmdPtr->flags & CMD_HAS_EXEC_TRACES
|| ((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE) {
/*
* Maps to an undefined command or a command without a compiler.
* Cannot compile.
*/
goto cleanup;
}
cmdPtr = newCmdPtr;
depth++;
/*
* See whether we have a nested ensemble. If we do, we can go round the
|
| ︙ | ︙ | |||
3190 3191 3192 3193 3194 3195 3196 |
}
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc > eclIndex + 1) {
| | | | | | 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 |
}
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc > eclIndex + 1) {
mapPtr->nuloc--;
Tcl_Free(mapPtr->loc[mapPtr->nuloc].line);
mapPtr->loc[mapPtr->nuloc].line = NULL;
}
/*
* Reset the index of next command. Toss out any from failed nested
* partial compiles.
*/
envPtr->numCommands = mapPtr->nuloc;
/*
* Failed to do a full compile for some reason. Try to do a direct invoke
* instead of going through the ensemble lookup process again.
*/
tryCompileToInv:
if (depth < 250) {
if (depth > 1) {
if (!invokeAnyway) {
cmdPtr = oldCmdPtr;
depth--;
}
}
|
| ︙ | ︙ | |||
3402 3403 3404 3405 3406 3407 3408 |
/*
* Push the words of the command. Take care; the command words may be
* scripts that have backslashes in them, and [info frame 0] can see the
* difference. Hence the call to TclContinuationsEnterDerived...
*/
| | | | 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 |
/*
* Push the words of the command. Take care; the command words may be
* scripts that have backslashes in them, and [info frame 0] can see the
* difference. Hence the call to TclContinuationsEnterDerived...
*/
TclListObjGetElements(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i <= numWords) {
bytes = TclGetStringFromObj(words[i - 1], &length);
PushLiteral(envPtr, bytes, length);
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterLiteral(envPtr,
|
| ︙ | ︙ | |||
3435 3436 3437 3438 3439 3440 3441 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
| | | > | 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 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = TclGetStringFromObj(objPtr, &length);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
/*
* Do the replacing dispatch.
*/
TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,
numWords + 1);
}
/*
* Helpers that do issuing of instructions for commands that "don't have
* compilers" (well, they do; these). They all work by just generating base
* code to invoke the command; they're intended for ensemble subcommands so
* that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
|
| ︙ | ︙ |
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ #if defined(_WIN32) # define tenviron _wenviron # define tenviron2utfdstr(str, dsPtr) (Tcl_DStringInit(dsPtr), \ | | | | | < | 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 |
#include "tclInt.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
#if defined(_WIN32)
# define tenviron _wenviron
# define tenviron2utfdstr(str, dsPtr) (Tcl_DStringInit(dsPtr), \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(str), -1, (dsPtr)))
# define utf2tenvirondstr(str, dsPtr) (Tcl_DStringInit(dsPtr), \
(const WCHAR *)Tcl_UtfToChar16DString((str), -1, (dsPtr)))
# define techar WCHAR
# ifdef USE_PUTENV
# define putenv(env) _wputenv((const wchar_t *)env)
# endif
#else
# define tenviron environ
# define tenviron2utfdstr(str, dsPtr) \
Tcl_ExternalToUtfDString(NULL, str, -1, dsPtr)
# define utf2tenvirondstr(str, dsPtr) \
Tcl_UtfToExternalDString(NULL, str, -1, dsPtr)
# define techar char
#endif
/* MODULE_SCOPE */
size_t TclEnvEpoch = 0; /* Epoch of the tcl environment
* (if changed with tcl-env). */
static struct {
Tcl_Size cacheSize; /* Number of env strings in cache. */
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclUuid.h" /* * The data structure below is used to report background errors. One such * structure is allocated for each error; it holds information about the * interpreter and the error until an idle handler command can be invoked. */ | > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclUuid.h" #ifdef TCL_WITH_INTERNAL_ZLIB #include "zlib.h" #endif /* TCL_WITH_INTERNAL_ZLIB */ /* * The data structure below is used to report background errors. One such * structure is allocated for each error; it holds information about the * interpreter and the error until an idle handler command can be invoked. */ |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | /* * This variable contains the application wide exit handler. It will be called * by Tcl_Exit instead of the C-runtime exit if this variable is set to a * non-NULL value. */ | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
/*
* This variable contains the application wide exit handler. It will be called
* by Tcl_Exit instead of the C-runtime exit if this variable is set to a
* non-NULL value.
*/
static Tcl_ExitProc *appExitPtr = NULL;
typedef struct ThreadSpecificData {
ExitHandler *firstExitPtr; /* First in list of all exit handlers for this
* thread. */
int inExit; /* True when this thread is exiting. This is
* used as a hack to decide to close the
* standard channels. */
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | * support one handler setting another handler. */ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; | | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | * support one handler setting another handler. */ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL); |
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
Tcl_Free(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
| | < < | < < | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
Tcl_Free(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *valuePtr = NULL;
TclDictGet(NULL, options, "-errorinfo", &valuePtr);
Tcl_WriteChars(errChannel,
"error in background error handler:\n", -1);
if (valuePtr) {
if (Tcl_WriteObj(errChannel, valuePtr) < 0) {
Tcl_WriteChars(errChannel, ENCODING_ERROR, -1);
}
} else {
|
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
int
TclDefaultBgErrorHandlerObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | < < | < | < < | < | | 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 |
int
TclDefaultBgErrorHandlerObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *valuePtr;
Tcl_Obj *tempObjv[2];
int result, code, level;
Tcl_InterpState saved;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "msg options");
return TCL_ERROR;
}
/*
* Check for a valid return options dictionary.
*/
result = TclDictGet(NULL, objv[2], "-level", &valuePtr);
if (result != TCL_OK || valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-level\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
return TCL_ERROR;
}
result = TclDictGet(NULL, objv[2], "-code", &valuePtr);
if (result != TCL_OK || valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-code\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
return TCL_ERROR;
}
if (level != 0) {
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 |
}
Tcl_IncrRefCount(tempObjv[1]);
if (code != TCL_ERROR) {
Tcl_SetObjResult(interp, tempObjv[1]);
}
| < < | < < < | < | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
}
Tcl_IncrRefCount(tempObjv[1]);
if (code != TCL_ERROR) {
Tcl_SetObjResult(interp, tempObjv[1]);
}
result = TclDictGet(NULL, objv[2], "-errorcode", &valuePtr);
if (result == TCL_OK && valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
}
result = TclDictGet(NULL, objv[2], "-errorinfo", &valuePtr);
if (result == TCL_OK && valuePtr != NULL) {
Tcl_AppendObjToErrorInfo(interp, valuePtr);
}
if (code == TCL_ERROR) {
Tcl_SetObjResult(interp, tempObjv[1]);
}
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 | * Sets the application wide exit handler to the specified value. * *---------------------------------------------------------------------- */ Tcl_ExitProc * Tcl_SetExitProc( | | < | 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 |
* Sets the application wide exit handler to the specified value.
*
*----------------------------------------------------------------------
*/
Tcl_ExitProc *
Tcl_SetExitProc(
Tcl_ExitProc *proc) /* New exit handler for app or NULL */
{
Tcl_ExitProc *prevExitProc;
/*
* Swap the old exit proc for the new one, saving the old one for our
* return value.
*/
Tcl_MutexLock(&exitMutex);
prevExitProc = appExitPtr;
appExitPtr = proc;
Tcl_MutexUnlock(&exitMutex);
return prevExitProc;
}
/*
*----------------------------------------------------------------------
*
* InvokeExitHandlers --
*
* Call the registered exit handlers.
|
| ︙ | ︙ | |||
931 932 933 934 935 936 937 |
exitPtr->proc(exitPtr->clientData);
Tcl_Free(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
}
| < | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
exitPtr->proc(exitPtr->clientData);
Tcl_Free(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Exit --
*
* This function is called to terminate the application.
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 |
*/
TCL_NORETURN void
Tcl_Exit(
int status) /* Exit status for application; typically 0
* for normal return, 1 for error return. */
{
| | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
*/
TCL_NORETURN void
Tcl_Exit(
int status) /* Exit status for application; typically 0
* for normal return, 1 for error return. */
{
Tcl_ExitProc *currentAppExitPtr;
Tcl_MutexLock(&exitMutex);
currentAppExitPtr = appExitPtr;
Tcl_MutexUnlock(&exitMutex);
/*
* Warning: this function SHOULD NOT return, as there is code that depends
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
* Tcl_Channels that may have data enqueued.
*/
FinalizeThread(/* quick */ 1);
}
}
| | < | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
* Tcl_Channels that may have data enqueued.
*/
FinalizeThread(/* quick */ 1);
}
}
exit(status);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_InitSubsystems --
*
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
#endif
#ifdef PURIFY
".purify"
#endif
#ifdef STATIC_BUILD
".static"
#endif
}};
const char *
Tcl_InitSubsystems(void)
{
if (inExit != 0) {
Tcl_Panic("Tcl_InitSubsystems called while exiting");
| > > > > > > > > > > > > > > | 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 |
#endif
#ifdef PURIFY
".purify"
#endif
#ifdef STATIC_BUILD
".static"
#endif
#ifndef TCL_WITH_EXTERNAL_TOMMATH
".tommath-0103"
#endif
#ifdef TCL_WITH_INTERNAL_ZLIB
".zlib-"
#if ZLIB_VER_MAJOR < 10
"0"
#endif
STRINGIFY(ZLIB_VER_MAJOR)
#if ZLIB_VER_MINOR < 10
"0"
#endif
STRINGIFY(ZLIB_VER_MINOR)
#endif // TCL_WITH_INTERNAL_ZLIB
}};
const char *
Tcl_InitSubsystems(void)
{
if (inExit != 0) {
Tcl_Panic("Tcl_InitSubsystems called while exiting");
|
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
* Legacy "vwait" syntax, skip option handling.
*/
i = 1;
goto endOfOptionLoop;
}
if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) {
| | | 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 |
* Legacy "vwait" syntax, skip option handling.
*/
i = 1;
goto endOfOptionLoop;
}
if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) {
vwaitItems = (VwaitItem *)Tcl_Alloc(sizeof(VwaitItem) * (objc - 1));
}
for (i = 1; i < objc; i++) {
const char *name;
name = TclGetString(objv[i]);
if (name[0] != '-') {
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
break;
case OPT_TIMEOUT:
if (++i >= objc) {
needArg:
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"argument required for \"%s\"", vWaitOptionStrings[index]));
| | | | | | | 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 |
break;
case OPT_TIMEOUT:
if (++i >= objc) {
needArg:
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"argument required for \"%s\"", vWaitOptionStrings[index]));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", (char *)NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (timeout < 0) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"timeout must be positive", -1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", (char *)NULL);
result = TCL_ERROR;
goto done;
}
break;
case OPT_LAST:
i++;
goto endOfOptionLoop;
case OPT_VARIABLE:
if (++i >= objc) {
goto needArg;
}
result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &vwaitItems[numItems]);
if (result != TCL_OK) {
goto done;
}
vwaitItems[numItems].donePtr = &done;
vwaitItems[numItems].sequence = -1;
vwaitItems[numItems].mask = 0;
vwaitItems[numItems].sourceObj = objv[i];
numItems++;
break;
case OPT_READABLE:
if (++i >= objc) {
goto needArg;
}
if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
!= TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't open for reading",
TclGetString(objv[i])));
|
| ︙ | ︙ | |||
1629 1630 1631 1632 1633 1634 1635 |
numItems++;
break;
case OPT_WRITABLE:
if (++i >= objc) {
goto needArg;
}
if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
| | | 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 |
numItems++;
break;
case OPT_WRITABLE:
if (++i >= objc) {
goto needArg;
}
if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
!= TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't open for writing",
TclGetString(objv[i])));
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 |
numItems++;
break;
}
}
endOfOptionLoop:
if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
| | | | | | | | | 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 |
numItems++;
break;
}
}
endOfOptionLoop:
if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't wait: would block forever", -1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (char *)NULL);
result = TCL_ERROR;
goto done;
}
if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"timer events disabled with timeout specified", -1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", (char *)NULL);
result = TCL_ERROR;
goto done;
}
for (result = TCL_OK; i < objc; i++) {
result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &vwaitItems[numItems]);
if (result != TCL_OK) {
break;
}
vwaitItems[numItems].donePtr = &done;
vwaitItems[numItems].sequence = -1;
vwaitItems[numItems].mask = 0;
vwaitItems[numItems].sourceObj = objv[i];
numItems++;
}
if (result != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (!(mask & TCL_FILE_EVENTS)) {
for (i = 0; i < numItems; i++) {
if (vwaitItems[i].mask) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"file events disabled with channel(s) specified", -1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", (char *)NULL);
result = TCL_ERROR;
goto done;
}
}
}
if (timeout > 0) {
vwaitItems[numItems].donePtr = &timedOut;
vwaitItems[numItems].sequence = -1;
vwaitItems[numItems].mask = 0;
vwaitItems[numItems].sourceObj = NULL;
timer = Tcl_CreateTimerHandler(timeout, VwaitTimeoutProc,
&vwaitItems[numItems]);
Tcl_GetTime(&before);
} else {
timeout = 0;
}
if ((numItems == 0) && (timeout == 0)) {
/*
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 |
foundEvent = Tcl_DoOneEvent(mask);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
| | | | 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 |
foundEvent = Tcl_DoOneEvent(mask);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", (char *)NULL);
break;
}
if ((numItems == 0) && (timeout == 0)) {
/*
* Behavior like "update": clear interpreter's result because
* event handlers could have executed commands.
*/
Tcl_ResetResult(interp);
result = TCL_OK;
goto done;
}
}
if (!foundEvent) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj((numItems == 0) ?
"can't wait: would wait forever" :
"can't wait for variable(s)/channel(s): would wait forever",
-1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (char *)NULL);
result = TCL_ERROR;
goto done;
}
if (!done && !timedOut) {
/*
* The interpreter's result was already set to the right error message
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
188 189 190 191 192 193 194 | * We use the new compile-time assertions to check that nCleanup is constant * and within range. */ /* Verify the stack depth, only when no expansion is in progress */ #ifdef TCL_COMPILE_DEBUG | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
* We use the new compile-time assertions to check that nCleanup is constant
* and within range.
*/
/* Verify the stack depth, only when no expansion is in progress */
#ifdef TCL_COMPILE_DEBUG
#define CHECK_STACK() \
do { \
ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
/*checkStack*/ !(starting || auxObjList)); \
starting = 0; \
} while (0)
#else
#define CHECK_STACK()
#endif
#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
do { \
TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \
CHECK_STACK(); \
if (nCleanup == 0) { \
if (resultHandling != 0) { \
if ((resultHandling) > 0) { \
PUSH_OBJECT(objResultPtr); \
} else { \
*(++tosPtr) = objResultPtr; \
} \
} \
pc += (pcAdjustment); \
goto cleanup0; \
} else if (resultHandling != 0) { \
if ((resultHandling) > 0) { \
Tcl_IncrRefCount(objResultPtr); \
} \
pc += (pcAdjustment); \
switch (nCleanup) { \
case 1: goto cleanup1_pushObjResultPtr; \
case 2: goto cleanup2_pushObjResultPtr; \
case 0: break; \
} \
} else { \
pc += (pcAdjustment); \
switch (nCleanup) { \
case 1: goto cleanup1; \
case 2: goto cleanup2; \
case 0: break; \
} \
} \
} while (0)
#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
CHECK_STACK(); \
do { \
pc += (pcAdjustment); \
cleanup = (nCleanup); \
if (resultHandling) { \
if ((resultHandling) > 0) { \
Tcl_IncrRefCount(objResultPtr); \
} \
goto cleanupV_pushObjResultPtr; \
} else { \
goto cleanupV; \
} \
} while (0)
#ifndef TCL_COMPILE_DEBUG
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do { \
pc += (pcAdjustment); \
switch (*pc) { \
case INST_JUMP_FALSE1: \
NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE1: \
NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
break; \
case INST_JUMP_FALSE4: \
NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE4: \
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
break; \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
NEXT_INST_F(0, (cleanup), 1); \
break; \
} \
} while (0)
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do { \
pc += (pcAdjustment); \
switch (*pc) { \
case INST_JUMP_FALSE1: \
NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE1: \
NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
break; \
case INST_JUMP_FALSE4: \
NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE4: \
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
break; \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
NEXT_INST_V(0, (cleanup), 1); \
break; \
} \
} while (0)
#else /* TCL_COMPILE_DEBUG */
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 |
#define PUSH_OBJECT(objPtr) \
Tcl_IncrRefCount(*(++tosPtr) = (objPtr))
#define POP_OBJECT() *(tosPtr--)
#define OBJ_AT_TOS *tosPtr
| | | | | > | | | | | | | > | | | | | | | | 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 |
#define PUSH_OBJECT(objPtr) \
Tcl_IncrRefCount(*(++tosPtr) = (objPtr))
#define POP_OBJECT() *(tosPtr--)
#define OBJ_AT_TOS *tosPtr
#define OBJ_UNDER_TOS tosPtr[-1]
#define OBJ_AT_DEPTH(n) tosPtr[-(n)]
#define CURR_DEPTH (tosPtr - initTosPtr)
#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
/*
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
* only used in TRACE* calls to get a string from an object.
*/
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
while (traceInstructions) { \
fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER \
"d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \
CURR_DEPTH, \
(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
break; \
}
# define TRACE_APPEND(a) \
while (traceInstructions) { \
printf a; \
break; \
}
# define TRACE_ERROR(interp) \
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
# define TRACE_WITH_OBJ(a, objPtr) \
while (traceInstructions) { \
fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER \
"d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \
CURR_DEPTH, \
(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
fprintf(stdout, "\n"); \
break; \
}
# define O2S(objPtr) \
(objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
# define TRACE(a)
# define TRACE_APPEND(a)
# define TRACE_ERROR(interp)
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 | * Tcl_GetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * void **ptrPtr, int *tPtr); */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ | | | | | > | 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 |
* Tcl_GetNumberFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* void **ptrPtr, int *tPtr);
*/
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
((TclHasInternalRep((objPtr), &tclIntType)) \
? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
TclHasInternalRep((objPtr), &tclDoubleType) \
? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
? TCL_ERROR : \
Tcl_GetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
/*
* Macro used to make the check for type overflow more mnemonic. This works by
* comparing sign bits; the rest of the word is irrelevant. The ANSI C
* "prototype" (where inttype_t is any integer type) is:
*
* MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum);
*
* Check first the condition most likely to fail in usual code (at least for
* usage in [incr]: do the first summand and the sum have != signs?
*/
#define Overflowing(a,b,sum) \
((((a)^(sum)) < 0) && (((a)^(b)) >= 0))
/*
* Macro for checking whether the type is NaN, used when we're thinking about
* throwing an error for supplying a non-number number.
*/
#ifndef ACCEPT_NAN
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 | static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, Tcl_Size *lengthPtr, const unsigned char **pcBeg, Tcl_Size *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth, int move); | | | | 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 |
static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc,
int searchMode, ByteCode *codePtr);
static const char * GetSrcInfoForPc(const unsigned char *pc,
ByteCode *codePtr, Tcl_Size *lengthPtr,
const unsigned char **pcBeg, Tcl_Size *cmdIdxPtr);
static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth,
int move);
static void IllegalExprOperandType(Tcl_Interp *interp, const char *ord,
const unsigned char *pc, Tcl_Obj *opndPtr);
static void InitByteCodeExecution(Tcl_Interp *interp);
static inline int wordSkip(void *ptr);
static void ReleaseDictIterator(Tcl_Obj *objPtr);
/* Useful elsewhere, make available in tclInt.h or stubs? */
static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, size_t numWords);
static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, size_t numWords);
static Tcl_NRPostProc CopyCallback;
static Tcl_NRPostProc ExprObjCallback;
static Tcl_NRPostProc FinalizeOONext;
static Tcl_NRPostProc FinalizeOONextFilter;
static Tcl_NRPostProc TEBCresume;
/*
* The structure below defines a bytecode Tcl object type to hold the
* compiled bytecode for Tcl expressions.
*/
const Tcl_ObjType tclExprCodeType = {
"exprcode",
FreeExprCodeInternalRep, /* freeIntRepProc */
DupExprCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 |
* the marker, (WALLOCALIGN-1) for the maximal possible offset.
*/
if (move) {
moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
}
needed = growth + moveWords + WALLOCALIGN;
| < | 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
* the marker, (WALLOCALIGN-1) for the maximal possible offset.
*/
if (move) {
moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
}
needed = growth + moveWords + WALLOCALIGN;
/*
* Check if there is enough room in the next stack (if there is one, it
* should be both empty and the last one!)
*/
if (esPtr->nextPtr) {
|
| ︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 |
CompileExprObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
| | < | | | | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 |
CompileExprObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. Initialized
* to avoid compiler warning. */
/*
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr);
if (codePtr != NULL) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
Tcl_StoreInternalRep(objPtr, &tclExprCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
Tcl_Size length;
const char *string = TclGetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
TclCompileExpr(interp, string, length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
* push an zero object as the expression's result.
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 | /* * Add a "done" instruction as the last instruction and change the * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); | | < < | < < < | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
/*
* Add a "done" instruction as the last instruction and change the
* object into a ByteCode object. Ownership of the literal objects and
* aux data items is given to the ByteCode object.
*/
TclEmitOpcode(INST_DONE, &compEnv);
codePtr = TclInitByteCodeObj(objPtr, &tclExprCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
TclDebugPrintByteCodeObj(objPtr);
}
return codePtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1529 1530 1531 1532 1533 1534 1535 |
*/
static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
ByteCode *codePtr;
| | | 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
*/
static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
ByteCode *codePtr;
ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1559 1560 1561 1562 1563 1564 1565 |
TclCompileObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const CmdFrame *invoker,
int word)
{
Interp *iPtr = (Interp *) interp;
| | | 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 |
TclCompileObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const CmdFrame *invoker,
int word)
{
Interp *iPtr = (Interp *) interp;
ByteCode *codePtr; /* Tcl Internal type of bytecode. */
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
/*
* If the object is not already of tclByteCodeType, compile it (and reset
* the compilation flags in the interpreter; this should be done after any
* compilation). Otherwise, check that it is "fresh" enough.
*/
|
| ︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 |
static void
ArgumentBCEnter(
Tcl_Interp *interp,
ByteCode *codePtr,
TEBCdata *tdPtr,
const unsigned char *pc,
| | | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 |
static void
ArgumentBCEnter(
Tcl_Interp *interp,
ByteCode *codePtr,
TEBCdata *tdPtr,
const unsigned char *pc,
Tcl_Size objc,
Tcl_Obj **objv)
{
Tcl_Size cmd;
if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd,
pc - codePtr->codeStart);
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 |
/*
* Globals: variables that store state, must remain valid at all times.
*/
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc = (const unsigned char *)data[1];
| | | | | 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 |
/*
* Globals: variables that store state, must remain valid at all times.
*/
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc = (const unsigned char *)data[1];
/* The current program counter. */
unsigned char inst; /* The currently running instruction */
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
*/
int cleanup = PTR2INT(data[2]);
Tcl_Obj *objResultPtr;
int checkInterp = 0; /* Indicates when a check of interp readyness
* is necessary. Set by CACHE_STACK_INFO() */
/*
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
* NOTE: These are now mostly defined locally where needed.
*/
|
| ︙ | ︙ | |||
2087 2088 2089 2090 2091 2092 2093 |
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
}
goto cleanup0;
} else {
| | | 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 |
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
}
goto cleanup0;
} else {
/* resume from invocation */
CACHE_STACK_INFO();
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
if (bcFramePtr->cmdObj) {
Tcl_DecrRefCount(bcFramePtr->cmdObj);
bcFramePtr->cmdObj = NULL;
bcFramePtr->cmd = NULL;
|
| ︙ | ︙ | |||
2277 2278 2279 2280 2281 2282 2283 |
TCL_DTRACE_INST_NEXT();
if (inst == INST_LOAD_SCALAR1) {
goto instLoadScalar1;
} else if (inst == INST_PUSH1) {
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
| | | | | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 |
TCL_DTRACE_INST_NEXT();
if (inst == INST_LOAD_SCALAR1) {
goto instLoadScalar1;
} else if (inst == INST_PUSH1) {
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc + 1)), OBJ_AT_TOS);
inst = *(pc += 2);
goto peepholeStart;
} else if (inst == INST_START_CMD) {
/*
* Peephole: do not run INST_START_CMD, just skip it
*/
iPtr->cmdCount += TclGetUInt4AtPtr(pc + 5);
if (checkInterp) {
if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
(codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
goto instStartCmdFailed;
}
checkInterp = 0;
}
inst = *(pc += 9);
goto peepholeStart;
} else if (inst == INST_NOP) {
|
| ︙ | ︙ | |||
2375 2376 2377 2378 2379 2380 2381 |
TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
if (!corPtr) {
TRACE_APPEND(("ERROR: yield outside coroutine\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yield can only be called in a coroutine", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
| | | 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 |
TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
if (!corPtr) {
TRACE_APPEND(("ERROR: yield outside coroutine\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yield can only be called in a coroutine", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
(char *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
if (traceInstructions) {
|
| ︙ | ︙ | |||
2406 2407 2408 2409 2410 2411 2412 |
if (!corPtr) {
TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
O2S(valuePtr)));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yieldto can only be called in a coroutine", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
| | | | 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 |
if (!corPtr) {
TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
O2S(valuePtr)));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yieldto can only be called in a coroutine", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
(char *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
TRACE(("[%.30s] => ERROR: yield in deleted\n",
O2S(valuePtr)));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yieldto called in deleted namespace", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
(char *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
if (traceInstructions) {
|
| ︙ | ︙ | |||
2470 2471 2472 2473 2474 2475 2476 |
TEBC_YIELD();
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
yieldParameter, NULL, NULL);
return TCL_OK;
}
case INST_TAILCALL: {
| | | | 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 |
TEBC_YIELD();
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
yieldParameter, NULL, NULL);
return TCL_OK;
}
case INST_TAILCALL: {
Tcl_Obj *listPtr;
opnd = TclGetUInt1AtPtr(pc+1);
if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tailcall can only be called from a proc or lambda", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
/* FIXME: What is the right thing to trace? */
{
|
| ︙ | ︙ | |||
2506 2507 2508 2509 2510 2511 2512 | /* * Push the evaluation of the called command into the NR callback * stack. */ listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); | > | < | 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 |
/*
* Push the evaluation of the called command into the NR callback
* stack.
*/
listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj(
(Tcl_Namespace *) iPtr->varFramePtr->nsPtr));
if (iPtr->varFramePtr->tailcallPtr) {
Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
}
iPtr->varFramePtr->tailcallPtr = listPtr;
result = TCL_RETURN;
cleanup = opnd;
|
| ︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 |
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_F(5, 0, 1);
break;
case INST_REVERSE: {
Tcl_Obj **a, **b;
| | | | | > | 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 |
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_F(5, 0, 1);
break;
case INST_REVERSE: {
Tcl_Obj **a, **b;
opnd = TclGetUInt4AtPtr(pc + 1);
a = tosPtr - (opnd - 1);
b = tosPtr;
while (a < b) {
tmpPtr = *a;
*a = *b;
*b = tmpPtr;
a++;
b--;
}
TRACE(("%u => OK\n", opnd));
NEXT_INST_F(5, 0, 0);
}
break;
case INST_STR_CONCAT1:
|
| ︙ | ︙ | |||
2615 2616 2617 2618 2619 2620 2621 |
case INST_CONCAT_STK:
/*
* Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
* and then decrement their ref counts.
*/
opnd = TclGetUInt4AtPtr(pc+1);
| | | 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 |
case INST_CONCAT_STK:
/*
* Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
* and then decrement their ref counts.
*/
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd - 1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
break;
case INST_EXPAND_START:
/*
* Push an element to the auxObjList. This records the current
|
| ︙ | ︙ | |||
2672 2673 2674 2675 2676 2677 2678 |
* Make sure that the element at stackTop is a list; if not, just
* leave with an error. Note that the element from the expand list
* will be removed at checkForCatch.
*/
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(objPtr)));
| | | 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 |
* Make sure that the element at stackTop is a list; if not, just
* leave with an error. Note that the element from the expand list
* will be removed at checkForCatch.
*/
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(objPtr)));
if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
(void) POP_OBJECT();
/*
* Make sure there is enough room in the stack to expand this list
|
| ︙ | ︙ | |||
2888 2889 2890 2891 2892 2893 2894 | DECACHE_STACK_INFO(); pc += 6; TEBC_YIELD(); TclMarkTailcall(interp); TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); | | | 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 |
DECACHE_STACK_INFO();
pc += 6;
TEBC_YIELD();
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
TclListObjGetElements(NULL, objPtr, &objc, &objv);
TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL);
/*
* -----------------------------------------------------------------
* Start of INST_LOAD instructions.
*
|
| ︙ | ︙ | |||
3119 3120 3121 3122 3123 3124 3125 |
valuePtr = varPtr->value.objPtr;
if (valuePtr != NULL) {
TclDecrRefCount(valuePtr);
}
objResultPtr = OBJ_AT_TOS;
varPtr->value.objPtr = objResultPtr;
#ifndef TCL_COMPILE_DEBUG
| | | 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 |
valuePtr = varPtr->value.objPtr;
if (valuePtr != NULL) {
TclDecrRefCount(valuePtr);
}
objResultPtr = OBJ_AT_TOS;
varPtr->value.objPtr = objResultPtr;
#ifndef TCL_COMPILE_DEBUG
if (pc[pcAdjustment] == INST_POP) {
tosPtr--;
NEXT_INST_F((pcAdjustment+1), 0, 0);
}
#else
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
Tcl_IncrRefCount(objResultPtr);
|
| ︙ | ︙ | |||
3178 3179 3180 3181 3182 3183 3184 |
if (part2Ptr == NULL) {
TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr)));
} else {
TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr)));
}
#endif
| | | 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 |
if (part2Ptr == NULL) {
TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr)));
} else {
TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr)));
}
#endif
varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (!varPtr) {
TRACE_ERROR(interp);
goto gotError;
}
cleanup = ((part2Ptr == NULL)? 2 : 3);
pcAdjustment = 1;
|
| ︙ | ︙ | |||
3283 3284 3285 3286 3287 3288 3289 |
part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
CACHE_STACK_INFO();
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
}
#ifndef TCL_COMPILE_DEBUG
| | | | 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 |
part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
CACHE_STACK_INFO();
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
}
#ifndef TCL_COMPILE_DEBUG
if (pc[pcAdjustment] == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
case INST_LAPPEND_LIST:
opnd = TclGetUInt4AtPtr(pc+1);
valuePtr = OBJ_AT_TOS;
varPtr = LOCAL(opnd);
cleanup = 1;
pcAdjustment = 5;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (TclIsVarDirectReadable(varPtr)
&& TclIsVarDirectWritable(varPtr)) {
goto lappendListDirect;
|
| ︙ | ︙ | |||
3326 3327 3328 3329 3330 3331 3332 |
cleanup = 2;
pcAdjustment = 5;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" \"%.30s\" => ",
opnd, O2S(part2Ptr), O2S(valuePtr)));
| | | 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 |
cleanup = 2;
pcAdjustment = 5;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" \"%.30s\" => ",
opnd, O2S(part2Ptr), O2S(valuePtr)));
if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)
&& !WriteTraced(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
|
| ︙ | ︙ | |||
3368 3369 3370 3371 3372 3373 3374 |
part2Ptr = NULL;
part1Ptr = OBJ_UNDER_TOS; /* variable name */
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr)));
goto lappendList;
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
| | | | 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 |
part2Ptr = NULL;
part1Ptr = OBJ_UNDER_TOS; /* variable name */
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr)));
goto lappendList;
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr);
TclDecrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr = newValue;
Tcl_IncrRefCount(newValue);
}
if (TclListObjAppendElements(interp, objResultPtr, objc, objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
lappendList:
opnd = -1;
if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
DECACHE_STACK_INFO();
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
|
| ︙ | ︙ | |||
3427 3428 3429 3430 3431 3432 3433 |
{
int createdNewObj = 0;
Tcl_Obj *valueToAssign;
if (!objResultPtr) {
valueToAssign = valuePtr;
| | | 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 |
{
int createdNewObj = 0;
Tcl_Obj *valueToAssign;
if (!objResultPtr) {
valueToAssign = valuePtr;
} else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
valueToAssign = Tcl_DuplicateObj(objResultPtr);
createdNewObj = 1;
} else {
|
| ︙ | ︙ | |||
3682 3683 3684 3685 3686 3687 3688 |
TRACE_ERROR(interp);
goto gotError;
}
}
doneIncr:
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
| | | 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 |
TRACE_ERROR(interp);
goto gotError;
}
}
doneIncr:
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
if (pc[pcAdjustment] == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
NEXT_INST_V(pcAdjustment, cleanup, 1);
}
/*
|
| ︙ | ︙ | |||
3769 3770 3771 3772 3773 3774 3775 |
doExistStk:
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access",
/*createPart1*/0, /*createPart2*/1, &arrayPtr);
if (varPtr) {
if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
DECACHE_STACK_INFO();
| | | 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 |
doExistStk:
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access",
/*createPart1*/0, /*createPart2*/1, &arrayPtr);
if (varPtr) {
if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
DECACHE_STACK_INFO();
TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, part2Ptr,
TCL_TRACE_READS, 0, -1);
CACHE_STACK_INFO();
}
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
varPtr = NULL;
}
|
| ︙ | ︙ | |||
3950 3951 3952 3953 3954 3955 3956 |
cleanup = 2;
part1Ptr = OBJ_UNDER_TOS;
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr)));
varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
/*createPart1*/1, /*createPart2*/0, &arrayPtr);
doConst:
| | | 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 |
cleanup = 2;
part1Ptr = OBJ_UNDER_TOS;
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr)));
varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
/*createPart1*/1, /*createPart2*/0, &arrayPtr);
doConst:
if (TclIsVarConstant(varPtr)) {
TRACE_APPEND(("\n"));
NEXT_INST_V(pcAdjustment, cleanup, 0);
}
if (TclIsVarArray(varPtr)) {
msgPart = "variable is array";
goto constError;
} else if (TclIsVarArrayElement(varPtr)) {
|
| ︙ | ︙ | |||
3985 3986 3987 3988 3989 3990 3991 |
}
TclSetVarConstant(varPtr);
TRACE_APPEND(("\n"));
NEXT_INST_V(pcAdjustment, cleanup, 0);
constError:
TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd);
| | | 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 |
}
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", (char *)NULL);
TRACE_ERROR(interp);
goto gotError;
}
/*
* End of INST_CONST instructions.
* -----------------------------------------------------------------
|
| ︙ | ︙ | |||
4066 4067 4068 4069 4070 4071 4072 | /* * Either an array element, or a scalar: lose! */ TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); DECACHE_STACK_INFO(); | | | 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 |
/*
* Either an array element, or a scalar: lose!
*/
TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
"variable isn't array", opnd);
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL);
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
TclInitArrayVar(varPtr);
#ifdef TCL_COMPILE_DEBUG
TRACE_APPEND(("done\n"));
|
| ︙ | ︙ | |||
4314 4315 4316 4317 4318 4319 4320 |
break;
/*
* -----------------------------------------------------------------
* Start of general introspector instructions.
*/
| | | < < < < < < < < | 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 |
break;
/*
* -----------------------------------------------------------------
* Start of general introspector instructions.
*/
case INST_NS_CURRENT:
objResultPtr = TclNewNamespaceObj(TclGetCurrentNamespace(interp));
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_COROUTINE_NAME: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
|
| ︙ | ︙ | |||
4367 4368 4369 4370 4371 4372 4373 |
}
if (framePtr == rootFramePtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(OBJ_AT_TOS)));
TRACE_ERROR(interp);
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
| | | 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 |
}
if (framePtr == rootFramePtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(OBJ_AT_TOS)));
TRACE_ERROR(interp);
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
TclGetString(OBJ_AT_TOS), (char *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
|
| ︙ | ︙ | |||
4407 4408 4409 4410 4411 4412 4413 |
if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) {
Tcl_DecrRefCount(objResultPtr);
instOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
| | | 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 |
if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) {
Tcl_DecrRefCount(objResultPtr);
instOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(OBJ_AT_TOS), (char *)NULL);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
NEXT_INST_F(1, 1, 1);
}
|
| ︙ | ︙ | |||
4436 4437 4438 4439 4440 4441 4442 |
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE(("=> ERROR: no TclOO call context\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"self may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
| | | 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 |
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE(("=> ERROR: no TclOO call context\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"self may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
OO_ERROR(interp, CONTEXT_REQUIRED);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
/*
* Call out to get the name; it's expensive to compute but cached.
|
| ︙ | ︙ | |||
4464 4465 4466 4467 4468 4469 4470 |
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE_APPEND(("ERROR: no TclOO call context\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"nextto may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
| | | | 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 |
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE_APPEND(("ERROR: no TclOO call context\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"nextto may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
OO_ERROR(interp, CONTEXT_REQUIRED);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
if (oPtr == NULL) {
TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
goto gotError;
} else {
Class *classPtr = oPtr->classPtr;
struct MInvoke *miPtr;
Tcl_Size i;
const char *methodType;
if (classPtr == NULL) {
TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(valuePtr)));
DECACHE_STACK_INFO();
OO_ERROR(interp, CLASS_REQUIRED);
CACHE_STACK_INFO();
goto gotError;
}
for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter &&
|
| ︙ | ︙ | |||
4536 4537 4538 4539 4540 4541 4542 |
|| miPtr->mPtr->declaringClassPtr != classPtr) {
continue;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s implementation by \"%s\" not reachable from here",
methodType, TclGetString(valuePtr)));
DECACHE_STACK_INFO();
| | < | | | 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 |
|| miPtr->mPtr->declaringClassPtr != classPtr) {
continue;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s implementation by \"%s\" not reachable from here",
methodType, TclGetString(valuePtr)));
DECACHE_STACK_INFO();
OO_ERROR(interp, CLASS_NOT_REACHABLE);
CACHE_STACK_INFO();
goto gotError;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s has no non-filter implementation by \"%s\"",
methodType, TclGetString(valuePtr)));
DECACHE_STACK_INFO();
OO_ERROR(interp, CLASS_NOT_THERE);
CACHE_STACK_INFO();
goto gotError;
}
case INST_TCLOO_NEXT:
opnd = TclGetUInt1AtPtr(pc+1);
objv = &OBJ_AT_DEPTH(opnd - 1);
framePtr = iPtr->varFramePtr;
skip = 1;
TRACE(("%d => ", opnd));
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE_APPEND(("ERROR: no TclOO call context\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"next may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
OO_ERROR(interp, CONTEXT_REQUIRED);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
newDepth = contextPtr->index + 1;
if (newDepth >= contextPtr->callPtr->numChain) {
|
| ︙ | ︙ | |||
4592 4593 4594 4595 4596 4597 4598 |
methodType = "method";
}
TRACE_APPEND(("ERROR: no TclOO next impl\n"));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
DECACHE_STACK_INFO();
| | | 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 |
methodType = "method";
}
TRACE_APPEND(("ERROR: no TclOO next impl\n"));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
DECACHE_STACK_INFO();
OO_ERROR(interp, NOTHING_NEXT);
CACHE_STACK_INFO();
goto gotError;
#ifdef TCL_COMPILE_DEBUG
} else if (tclTraceExec >= 2) {
int i;
if (traceInstructions) {
|
| ︙ | ︙ | |||
4682 4683 4684 4685 4686 4687 4688 |
case INST_TCLOO_NS:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
if (oPtr == NULL) {
TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
goto gotError;
}
| < < < < < | | | 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 |
case INST_TCLOO_NS:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
if (oPtr == NULL) {
TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
goto gotError;
}
objResultPtr = TclNewNamespaceObj(oPtr->namespacePtr);
TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
}
/*
* End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
int numIndices, nocase, match, cflags;
Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len;
|
| ︙ | ︙ | |||
4716 4717 4718 4719 4720 4721 4722 |
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
| | | | 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 |
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TclNewIntObj(objResultPtr, length);
TRACE_APPEND(("%" TCL_SIZE_MODIFIER "d\n", length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/* special case for AbstractList */
if (TclObjTypeHasProc(valuePtr, indexProc)) {
DECACHE_STACK_INFO();
length = TclObjTypeLength(valuePtr);
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
|
| ︙ | ︙ | |||
4759 4760 4761 4762 4763 4764 4765 |
/*
* Extract the desired list element.
*/
{
Tcl_Size value2Length;
Tcl_Obj *indexListPtr = value2Ptr;
| > | < | < | | < < < | 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 |
/*
* Extract the desired list element.
*/
{
Tcl_Size value2Length;
Tcl_Obj *indexListPtr = value2Ptr;
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
&& (!TclHasInternalRep(value2Ptr, &tclListType)
|| (Tcl_ListObjLength(interp, value2Ptr, &value2Length),
value2Length == 1
? (indexListPtr = TclListObjGetElement(value2Ptr, 0), 1)
: 0))) {
int code;
/* increment the refCount of value2Ptr because TclListObjGetElement may
* have just extracted it from a list in the condition for this block.
*/
Tcl_IncrRefCount(indexListPtr);
|
| ︙ | ︙ | |||
4825 4826 4827 4828 4829 4830 4831 | /* * Get the contents of the list, making sure that it really is a list * in the process. */ /* special case for AbstractList */ | | | 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 |
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
/* special case for AbstractList */
if (TclObjTypeHasProc(valuePtr, indexProc)) {
length = TclObjTypeLength(valuePtr);
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, length-1);
if (index >= 0 && index < length) {
/* Compute value @ index */
|
| ︙ | ︙ | |||
4849 4850 4851 4852 4853 4854 4855 | } pcAdjustment = 5; goto lindexFastPath2; } /* List case */ | | | 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 |
}
pcAdjustment = 5;
goto lindexFastPath2;
}
/* List case */
if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, objc - 1);
|
| ︙ | ︙ | |||
4924 4925 4926 4927 4928 4929 4930 |
/*
* Compute the new variable value.
*/
DECACHE_STACK_INFO();
if (TclObjTypeHasProc(valuePtr, setElementProc)) {
objResultPtr = TclObjTypeSetElement(interp,
| | | | | 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 |
/*
* Compute the new variable value.
*/
DECACHE_STACK_INFO();
if (TclObjTypeHasProc(valuePtr, setElementProc)) {
objResultPtr = TclObjTypeSetElement(interp,
valuePtr, numIndices,
&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
} else {
objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
}
if (!objResultPtr) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
|
| ︙ | ︙ | |||
4998 4999 5000 5001 5002 5003 5004 | TclGetInt4AtPtr(pc+5))); /* * Get the length of the list, making sure that it really is a list * in the process. */ | | | | 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 |
TclGetInt4AtPtr(pc+5)));
/*
* Get the length of the list, making sure that it really is a list
* in the process.
*/
if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
/*
* Skip a lot of work if we're about to throw the result away (common
* with uses of [lassign]).
*/
#ifndef TCL_COMPILE_DEBUG
if (pc[9] == INST_POP) {
NEXT_INST_F(10, 1, 0);
}
#endif
/* Every range of an empty list is an empty list */
if (objc == 0) {
/* avoid return of not canonical list (e. g. spaces in string repr.) */
|
| ︙ | ︙ | |||
5074 5075 5076 5077 5078 5079 5080 |
NEXT_INST_F(9, 1, 1);
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 |
NEXT_INST_F(9, 1, 1);
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
s1 = TclGetStringFromObj(valuePtr, &s1len);
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
if (TclObjTypeHasProc(value2Ptr, inOperProc) != NULL) {
int status = TclObjTypeInOperator(interp, valuePtr, value2Ptr, &match);
if (status != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
} else {
if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
match = 0;
if (length > 0) {
Tcl_Size i = 0;
Tcl_Obj *o;
int isAbstractList = TclObjTypeHasProc(value2Ptr, indexProc) != NULL;
/*
* An empty list doesn't match anything.
*/
do {
if (isAbstractList) {
DECACHE_STACK_INFO();
if (TclObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
} else {
Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
}
if (o != NULL) {
s2 = TclGetStringFromObj(o, &s2len);
} else {
s2 = "";
s2len = 0;
}
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
/* Could be an ephemeral abstract obj */
Tcl_BounceRefCount(o);
i++;
} while (i < length && match == 0);
}
}
if (*pc == INST_LIST_NOT_IN) {
match = !match;
}
TRACE_APPEND(("%d\n", match));
|
| ︙ | ︙ | |||
5166 5167 5168 5169 5170 5171 5172 |
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
}
| | < | 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 |
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
}
case INST_LREPLACE4: {
size_t numToDelete, numNewElems;
int end_indicator;
int haveSecondIndex, flags;
Tcl_Obj *fromIdxObj, *toIdxObj;
opnd = TclGetInt4AtPtr(pc + 1);
flags = TclGetInt1AtPtr(pc + 5);
|
| ︙ | ︙ | |||
5193 5194 5195 5196 5197 5198 5199 |
if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
DECACHE_STACK_INFO();
| | < | | < | | < < < < | < | < < < < | < | 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 |
if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, fromIdxObj, length - end_indicator,
&fromIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = 0;
} else if (fromIdx > length) {
fromIdx = length;
}
numToDelete = 0;
if (toIdxObj) {
if (TclGetIntForIndexM(interp, toIdxObj, length - end_indicator,
&toIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (toIdx != TCL_INDEX_NONE) {
if (toIdx > length) {
toIdx = length;
}
if (toIdx >= fromIdx) {
numToDelete = (size_t)toIdx - (size_t)fromIdx + 1;
}
}
}
CACHE_STACK_INFO();
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_DuplicateObj(valuePtr);
if (Tcl_ListObjReplace(interp, objResultPtr, fromIdx, numToDelete,
numNewElems, &OBJ_AT_DEPTH(numNewElems - 1)) != TCL_OK) {
TRACE_ERROR(interp);
Tcl_DecrRefCount(objResultPtr);
goto gotError;
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(6, opnd, 1);
} else {
if (Tcl_ListObjReplace(interp, valuePtr, fromIdx, numToDelete,
numNewElems, &OBJ_AT_DEPTH(numNewElems - 1)) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
NEXT_INST_V(6, opnd - 1, 0);
}
}
|
| ︙ | ︙ | |||
5333 5334 5335 5336 5337 5338 5339 |
TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength));
NEXT_INST_F(1, 1, 1);
case INST_STR_UPPER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
| | | | | 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 |
TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength));
NEXT_INST_F(1, 1, 1);
case INST_STR_UPPER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = TclGetStringFromObj(valuePtr, &slength);
TclNewStringObj(objResultPtr, s1, slength);
slength = Tcl_UtfToUpper(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, slength);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
slength = Tcl_UtfToUpper(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, slength);
TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_STR_LOWER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = TclGetStringFromObj(valuePtr, &slength);
TclNewStringObj(objResultPtr, s1, slength);
slength = Tcl_UtfToLower(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, slength);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
slength = Tcl_UtfToLower(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, slength);
TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_STR_TITLE:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = TclGetStringFromObj(valuePtr, &slength);
TclNewStringObj(objResultPtr, s1, slength);
slength = Tcl_UtfToTitle(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, slength);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
slength = Tcl_UtfToTitle(TclGetString(valuePtr));
|
| ︙ | ︙ | |||
5433 5434 5435 5436 5437 5438 5439 |
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
DECACHE_STACK_INFO();
| | < | < | 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 |
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
if (toIdx == TCL_INDEX_NONE) {
|
| ︙ | ︙ | |||
5492 5493 5494 5495 5496 5497 5498 |
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
slength = Tcl_GetCharLength(valuePtr) - 1;
TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
DECACHE_STACK_INFO();
| | < | < | < < | 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 |
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
slength = Tcl_GetCharLength(valuePtr) - 1;
TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) {
CACHE_STACK_INFO();
TclDecrRefCount(value3Ptr);
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
if ((toIdx < 0) || (fromIdx > slength) || (toIdx < fromIdx)) {
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
TclDecrRefCount(value3Ptr);
NEXT_INST_F(1, 0, 0);
}
if (fromIdx < 0) {
fromIdx = 0;
|
| ︙ | ︙ | |||
5579 5580 5581 5582 5583 5584 5585 |
ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
p = ustring1;
end = ustring1 + slength;
for (; ustring1 < end; ustring1++) {
if ((*ustring1 == *ustring2) &&
| | | | | | 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 |
ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
p = ustring1;
end = ustring1 + slength;
for (; ustring1 < end; ustring1++) {
if ((*ustring1 == *ustring2) &&
/* Fix bug [69218ab7b]: restrict max compare length. */
((end - ustring1) >= length2) && (length2 == 1 ||
memcmp(ustring1, ustring2,
sizeof(Tcl_UniChar) * length2) == 0)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
|
| ︙ | ︙ | |||
5692 5693 5694 5695 5696 5697 5698 |
{
const char *string1, *string2;
Tcl_Size trim1, trim2;
case INST_STR_TRIM_LEFT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
| | | | | | | | 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 |
{
const char *string1, *string2;
Tcl_Size trim1, trim2;
case INST_STR_TRIM_LEFT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = TclGetStringFromObj(value2Ptr, &length2);
string1 = TclGetStringFromObj(valuePtr, &slength);
trim1 = TclTrimLeft(string1, slength, string2, length2);
trim2 = 0;
goto createTrimmedString;
case INST_STR_TRIM_RIGHT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = TclGetStringFromObj(value2Ptr, &length2);
string1 = TclGetStringFromObj(valuePtr, &slength);
trim2 = TclTrimRight(string1, slength, string2, length2);
trim1 = 0;
goto createTrimmedString;
case INST_STR_TRIM:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = TclGetStringFromObj(value2Ptr, &length2);
string1 = TclGetStringFromObj(valuePtr, &slength);
trim1 = TclTrim(string1, slength, string2, length2, &trim2);
createTrimmedString:
/*
* Careful here; trim set often contains non-ASCII characters so we
* take care when printing. [Bug 971cb4f1db]
*/
|
| ︙ | ︙ | |||
5896 5897 5898 5899 5900 5901 5902 |
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
| | | | 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 |
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "left ", pc, valuePtr);
CACHE_STACK_INFO();
goto gotError;
}
if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
|| (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "right ", pc, value2Ptr);
CACHE_STACK_INFO();
goto gotError;
}
/*
* Check for common, simple case.
*/
|
| ︙ | ︙ | |||
5971 5972 5973 5974 5975 5976 5977 |
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
| | | 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 |
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
(char *)NULL);
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
|
| ︙ | ︙ | |||
6020 6021 6022 6023 6024 6025 6026 |
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
| | | 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 |
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
(char *)NULL);
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
|
| ︙ | ︙ | |||
6042 6043 6044 6045 6046 6047 6048 | */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", | | | 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 |
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *)NULL);
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else {
int shift = (int) w2;
/*
|
| ︙ | ︙ | |||
6117 6118 6119 6120 6121 6122 6123 |
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| IsErroringNaNType(type1)) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
O2S(value2Ptr), O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name: "null")));
DECACHE_STACK_INFO();
| | | | 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 |
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| IsErroringNaNType(type1)) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
O2S(value2Ptr), O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name: "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "left ", pc, valuePtr);
CACHE_STACK_INFO();
goto gotError;
}
#ifdef ACCEPT_NAN
if (type1 == TCL_NUMBER_NAN) {
/*
* NaN first argument -> result is also NaN.
*/
NEXT_INST_F(1, 1, 0);
}
#endif
if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
|| IsErroringNaNType(type2)) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(value2Ptr), O2S(valuePtr),
(value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "right ", pc, value2Ptr);
CACHE_STACK_INFO();
goto gotError;
}
#ifdef ACCEPT_NAN
if (type2 == TCL_NUMBER_NAN) {
/*
|
| ︙ | ︙ | |||
6280 6281 6282 6283 6284 6285 6286 |
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) {
TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
| | | 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 |
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) {
TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "", pc, valuePtr);
CACHE_STACK_INFO();
goto gotError;
}
/* TODO: Consider peephole opt. */
objResultPtr = TCONST(!b);
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 1, 1);
|
| ︙ | ︙ | |||
6302 6303 6304 6305 6306 6307 6308 |
/*
* ... ~$NonInteger => raise an error.
*/
TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
| | | 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 |
/*
* ... ~$NonInteger => raise an error.
*/
TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "", pc, valuePtr);
CACHE_STACK_INFO();
goto gotError;
}
if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *) ptr1);
if (Tcl_IsShared(valuePtr)) {
TclNewIntObj(objResultPtr, ~w1);
|
| ︙ | ︙ | |||
6334 6335 6336 6337 6338 6339 6340 |
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| IsErroringNaNType(type1)) {
TRACE_APPEND(("ERROR: illegal type %s \n",
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
| | | 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 |
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| IsErroringNaNType(type1)) {
TRACE_APPEND(("ERROR: illegal type %s \n",
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "", pc, valuePtr);
CACHE_STACK_INFO();
goto gotError;
}
switch (type1) {
case TCL_NUMBER_NAN:
/* -NaN => NaN */
TRACE_APPEND(("%s\n", O2S(valuePtr)));
|
| ︙ | ︙ | |||
6387 6388 6389 6390 6391 6392 6393 |
/*
* ... +$NonNumeric => raise an error.
*/
TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
DECACHE_STACK_INFO();
| | | | 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 |
/*
* ... +$NonNumeric => raise an error.
*/
TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "", pc, valuePtr);
CACHE_STACK_INFO();
goto gotError;
}
/* ... TryConvertToNumeric($NonNumeric) is acceptable */
TRACE_APPEND(("not numeric\n"));
NEXT_INST_F(1, 0, 0);
}
if (IsErroringNaNType(type1)) {
if (*pc == INST_UPLUS) {
/*
* ... +$NonNumeric => raise an error.
*/
TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, "", pc, valuePtr);
CACHE_STACK_INFO();
} else {
/*
* Numeric conversion of NaN -> error.
*/
TRACE_APPEND(("ERROR: IEEE floating pt error\n"));
|
| ︙ | ︙ | |||
6523 6524 6525 6526 6527 6528 6529 |
iterMax = 0;
listTmpDepth = numLists-1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
DECACHE_STACK_INFO();
| | | 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 |
iterMax = 0;
listTmpDepth = numLists-1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
DECACHE_STACK_INFO();
if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
objPtr = TclListObjCopy(NULL, listPtr);
|
| ︙ | ︙ | |||
6613 6614 6615 6616 6617 6618 6619 |
listPtr = OBJ_AT_DEPTH(listTmpDepth);
hasAbstractList = TclObjTypeHasProc(listPtr, indexProc) != 0;
DECACHE_STACK_INFO();
if (hasAbstractList) {
status = Tcl_ListObjLength(interp, listPtr, &listLen);
elements = NULL;
} else {
| | < | 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 |
listPtr = OBJ_AT_DEPTH(listTmpDepth);
hasAbstractList = TclObjTypeHasProc(listPtr, indexProc) != 0;
DECACHE_STACK_INFO();
if (hasAbstractList) {
status = Tcl_ListObjLength(interp, listPtr, &listLen);
elements = NULL;
} else {
status = TclListObjGetElements(
interp, listPtr, &listLen, &elements);
}
if (status != TCL_OK) {
CACHE_STACK_INFO();
goto gotError;
}
CACHE_STACK_INFO();
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
6875 6876 6877 6878 6879 6880 6881 |
}
if (!objResultPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
| | | 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 |
}
if (!objResultPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(OBJ_AT_TOS), (char *)NULL);
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+1, 1);
case INST_DICT_GET_DEF:
|
| ︙ | ︙ | |||
7011 7012 7013 7014 7015 7016 7017 |
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
| | | 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 |
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
if (pc[9] == INST_POP) {
NEXT_INST_V(10, cleanup, 0);
}
#endif
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(9, cleanup, 1);
case INST_DICT_APPEND:
|
| ︙ | ︙ | |||
7150 7151 7152 7153 7154 7155 7156 |
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
| | < | 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 |
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
if (pc[5] == INST_POP) {
NEXT_INST_F(6, 2, 0);
}
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 2, 1);
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
/*
* dictPtr is no longer on the stack, and we're not
* moving it into the internalrep of an iterator. We need
* to drop the refcount [Tcl Bug 9b352768e6].
*/
Tcl_DecrRefCount(dictPtr);
|
| ︙ | ︙ | |||
7252 7253 7254 7255 7256 7257 7258 |
CACHE_STACK_INFO();
if (dictPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
Tcl_IncrRefCount(dictPtr);
| | | 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 |
CACHE_STACK_INFO();
if (dictPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
Tcl_IncrRefCount(dictPtr);
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
|
| ︙ | ︙ | |||
7312 7313 7314 7315 7316 7317 7318 |
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
TRACE_APPEND(("storage was unset\n"));
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
| | | 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 |
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
TRACE_APPEND(("storage was unset\n"));
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
|| TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
allocdict = Tcl_IsShared(dictPtr);
if (allocdict) {
dictPtr = Tcl_DuplicateObj(dictPtr);
|
| ︙ | ︙ | |||
7371 7372 7373 7374 7375 7376 7377 |
TRACE_APPEND(("written back\n"));
NEXT_INST_F(9, 1, 0);
case INST_DICT_EXPAND:
dictPtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
| | | | | | 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 |
TRACE_APPEND(("written back\n"));
NEXT_INST_F(9, 1, 0);
case INST_DICT_EXPAND:
dictPtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_DICT_RECOMBINE_STK:
keysPtr = POP_OBJECT();
varNamePtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
TclDecrRefCount(keysPtr);
goto gotError;
}
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
if (varPtr == NULL) {
TRACE_ERROR(interp);
TclDecrRefCount(keysPtr);
goto gotError;
}
DECACHE_STACK_INFO();
result = TclDictWithFinish(interp, varPtr, arrayPtr, varNamePtr, NULL, -1,
objc, objv, keysPtr);
CACHE_STACK_INFO();
TclDecrRefCount(keysPtr);
if (result != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 2, 0);
case INST_DICT_RECOMBINE_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
listPtr = OBJ_UNDER_TOS;
keysPtr = OBJ_AT_TOS;
varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
O2S(keysPtr)));
if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
7445 7446 7447 7448 7449 7450 7451 |
break;
/*
* End of dictionary-related instructions.
* -----------------------------------------------------------------
*/
| | < | | | | | | | | | | | | | | | | | | | | | > | | | | | | | 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 |
break;
/*
* End of dictionary-related instructions.
* -----------------------------------------------------------------
*/
case INST_CLOCK_READ: { /* Read the wall clock */
Tcl_WideInt wval;
Tcl_Time now;
switch (TclGetUInt1AtPtr(pc+1)) {
case 0: /* clicks */
#ifdef TCL_WIDE_CLICKS
wval = TclpGetWideClicks();
#else
wval = (Tcl_WideInt)TclpGetClicks();
#endif
break;
case 1: /* microseconds */
Tcl_GetTime(&now);
wval = (Tcl_WideInt)now.sec * 1000000 + now.usec;
break;
case 2: /* milliseconds */
Tcl_GetTime(&now);
wval = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000;
break;
case 3: /* seconds */
Tcl_GetTime(&now);
wval = (Tcl_WideInt)now.sec;
break;
default:
Tcl_Panic("clockRead instruction with unknown clock#");
break;
}
TclNewIntObj(objResultPtr, wval);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(2, 0, 1);
}
break;
default:
Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Block for variables needed to process exception returns.
|
| ︙ | ︙ | |||
7580 7581 7582 7583 7584 7585 7586 |
* Division by zero in an expression. Control only reaches this point
* by "goto divideByZero".
*/
divideByZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
DECACHE_STACK_INFO();
| | | | | 7538 7539 7540 7541 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 |
* Division by zero in an expression. Control only reaches this point
* by "goto divideByZero".
*/
divideByZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", (char *)NULL);
CACHE_STACK_INFO();
goto gotError;
outOfMemory:
Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", (char *)NULL);
CACHE_STACK_INFO();
goto gotError;
/*
* Exponentiation of zero by negative number in an expression. Control
* only reaches this point by "goto exponOfZero".
*/
exponOfZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponentiation of zero by negative power", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"exponentiation of zero by negative power", (char *)NULL);
CACHE_STACK_INFO();
/*
* Almost all error paths feed through here rather than assigning to
* result themselves (for a small but consistent saving).
*/
|
| ︙ | ︙ | |||
7889 7890 7891 7892 7893 7894 7895 | /* * WidePwrSmallExpon -- * * Helper to calculate small powers of integers whose result is wide. */ static inline Tcl_WideInt | | > > | | 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 |
/*
* WidePwrSmallExpon --
*
* Helper to calculate small powers of integers whose result is wide.
*/
static inline Tcl_WideInt
WidePwrSmallExpon(
Tcl_WideInt w1,
long exponent)
{
Tcl_WideInt wResult;
wResult = w1 * w1; /* b**2 */
switch (exponent) {
case 2:
break;
case 3:
|
| ︙ | ︙ | |||
8202 8203 8204 8205 8206 8207 8208 |
/*
* Handle shifts within the native wide range.
*/
if ((type1 == TCL_NUMBER_INT)
&& ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
w1 = *((const Tcl_WideInt *)ptr1);
| | < | | 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 |
/*
* Handle shifts within the native wide range.
*/
if ((type1 == TCL_NUMBER_INT)
&& ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
w1 = *((const Tcl_WideInt *)ptr1);
if (!((w1 > 0 ? w1 : ~w1) & -(
((Tcl_WideUInt)1) << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
WIDE_RESULT((Tcl_WideUInt)w1 << shift);
}
}
} else {
/*
* Quickly force large right shifts to 0 or -1.
*/
|
| ︙ | ︙ | |||
8515 8516 8517 8518 8519 8520 8521 |
WIDE_RESULT(wResult);
}
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
| | > | | 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 |
WIDE_RESULT(wResult);
}
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
|| !TclHasInternalRep(value2Ptr, &tclIntType)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
err = mp_init(&bigResult);
if (err == MP_OKAY) {
/* Don't use "mp_expt_n" directly here, it doesn't exist in libtommath 1.2 */
err = TclBN_mp_expt_n(&big1, (int)w2, &bigResult);
}
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
mp_clear(&big1);
BIG_RESULT(&bigResult);
}
|
| ︙ | ︙ | |||
8595 8596 8597 8598 8599 8600 8601 |
if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
w1 = *((const Tcl_WideInt *)ptr1);
w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_ADD:
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
| | < | < | 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 |
if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
w1 = *((const Tcl_WideInt *)ptr1);
w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_ADD:
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) {
/*
* Check for overflow.
*/
if (Overflowing(w1, w2, wResult)) {
goto overflowBasic;
}
}
break;
case INST_SUB:
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2);
if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) {
/*
* Must check for overflow. The macro tests for overflows
* in sums by looking at the sign bits. As we have a
* subtraction here, we are adding -w2. As -w2 could in
* turn overflow, we test with ~w2 instead: it has the
* opposite sign bit to w2 so it does the job. Note that
* the only "bad" case (w2==0) is irrelevant for this
|
| ︙ | ︙ | |||
8677 8678 8679 8680 8681 8682 8683 |
}
overflowBasic:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
err = mp_init(&bigResult);
if (err == MP_OKAY) {
| | | | | | | 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 |
}
overflowBasic:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
err = mp_init(&bigResult);
if (err == MP_OKAY) {
switch (opcode) {
case INST_ADD:
err = mp_add(&big1, &big2, &bigResult);
break;
case INST_SUB:
err = mp_sub(&big1, &big2, &bigResult);
break;
case INST_MULT:
err = mp_mul(&big1, &big2, &bigResult);
break;
case INST_DIV:
if (mp_iszero(&big2)) {
mp_clear(&big1);
mp_clear(&big2);
mp_clear(&bigResult);
return DIVIDED_BY_ZERO;
}
err = mp_init(&bigRemainder);
|
| ︙ | ︙ | |||
8981 8982 8983 8984 8985 8986 8987 | * None. * *---------------------------------------------------------------------- */ static void PrintByteCodeInfo( | | > > | > > > | > > > | > | > | > | 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 |
* None.
*
*----------------------------------------------------------------------
*/
static void
PrintByteCodeInfo(
ByteCode *codePtr) /* The bytecode whose summary is printed to
* stdout. */
{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
fprintf(stdout,
"\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER
"u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %"
TCL_Z_MODIFIER "u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
fprintf(stdout,
"\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER
"u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER
"u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER
"u, code/src %.2f\n",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
codePtr->numSrcBytes?
((float)codePtr->structureSize)/codePtr->numSrcBytes :
#endif
0.0);
#ifdef TCL_COMPILE_STATS
fprintf(stdout,
" Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER
"u+inst %" TCL_Z_MODIFIER "u+litObj %" TCL_Z_MODIFIER
"u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER
"u+cmdMap %" TCL_Z_MODIFIER "u\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 (procPtr != NULL) {
fprintf(stdout,
" Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %"
TCL_Z_MODIFIER "u, compiled locals %" TCL_Z_MODIFIER "u\n",
procPtr, procPtr->refCount, procPtr->numArgs,
procPtr->numCompiledLocals);
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
|
| ︙ | ︙ | |||
9045 9046 9047 9048 9049 9050 9051 | * *---------------------------------------------------------------------- */ #ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop( | | | 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(
ByteCode *codePtr, /* The bytecode whose summary is printed to
* stdout. */
const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
size_t stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int checkStack) /* 0 if the stack depth check should be
|
| ︙ | ︙ | |||
9073 9074 9075 9076 9077 9078 9079 |
Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if (opCode >= LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
| < | | | 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 |
Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if (opCode >= LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack && (stackTop > stackUpperBound)) {
Tcl_Size numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)",
stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
fprintf(stderr, "%s\n", TclGetString(message));
Tcl_DecrRefCount(message);
} else {
fprintf(stderr, "\n");
}
Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top");
}
}
|
| ︙ | ︙ | |||
9118 9119 9120 9121 9122 9123 9124 |
*----------------------------------------------------------------------
*/
static void
IllegalExprOperandType(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
| > | > > > > > > > > > > > > > > > > > > > | | | | 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 |
*----------------------------------------------------------------------
*/
static void
IllegalExprOperandType(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
const char *ord, /* "first ", "second " or "" */
const unsigned char *pc, /* Points to the instruction being executed
* when the illegal type was found. */
Tcl_Obj *opndPtr) /* Points to the operand holding the value
* with the illegal type. */
{
void *ptr;
int type;
const unsigned char opcode = *pc;
const char *description, *op = "unknown";
if (opcode == INST_EXPON) {
op = "**";
} else if (opcode <= INST_LNOT) {
op = operatorStrings[opcode - INST_BITOR];
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
Tcl_Size length;
if (TclHasInternalRep(opndPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, opndPtr, &length);
if (length > 0) {
listRep:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot use a list as %soperand of \"%s\"", ord, op));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "list", (char *)NULL);
return;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(opndPtr, lengthProc);
Tcl_Size objcPtr;
Tcl_Obj **objvPtr;
if ((lengthProc && lengthProc(opndPtr) > 1)
|| ((TclMaxListLength(TclGetString(opndPtr), TCL_INDEX_NONE, NULL) > 1)
&& (Tcl_ListObjGetElements(NULL, opndPtr, &objcPtr, &objvPtr) == TCL_OK))) {
goto listRep;
}
description = "non-numeric string";
} else if (type == TCL_NUMBER_NAN) {
description = "non-numeric floating-point value";
} else if (type == TCL_NUMBER_DOUBLE) {
description = "floating-point value";
} else {
/* TODO: No caller needs this. Eliminate? */
description = "(big) integer";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot use %s \"%s\" as %soperand of \"%s\"", description,
TclGetString(opndPtr), ord, op));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (char *)NULL);
}
/*
*----------------------------------------------------------------------
*
* TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
*
|
| ︙ | ︙ | |||
9178 9179 9180 9181 9182 9183 9184 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetSourceFromFrame(
CmdFrame *cfPtr,
| | | | | | | | | 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetSourceFromFrame(
CmdFrame *cfPtr,
Tcl_Size objc,
Tcl_Obj *const objv[])
{
if (cfPtr == NULL) {
return Tcl_NewListObj(objc, objv);
}
if (cfPtr->cmdObj == NULL) {
if (cfPtr->cmd == NULL) {
ByteCode *codePtr = (ByteCode *)cfPtr->data.tebc.codePtr;
cfPtr->cmd = GetSrcInfoForPc((unsigned char *)
cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL);
}
if (cfPtr->cmd) {
cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len);
} else {
cfPtr->cmdObj = Tcl_NewListObj(objc, objv);
}
Tcl_IncrRefCount(cfPtr->cmdObj);
}
return cfPtr->cmdObj;
}
void
TclGetSrcInfoForPc(
CmdFrame *cfPtr)
|
| ︙ | ︙ | |||
9526 9527 9528 9529 9530 9531 9532 |
* distinguish underflows from overflows. */
{
const char *s;
if ((errno == EDOM) || isnan(value)) {
s = "domain error: argument not in valid range";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
| | | | | | 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 |
* distinguish underflows from overflows. */
{
const char *s;
if ((errno == EDOM) || isnan(value)) {
s = "domain error: argument not in valid range";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *)NULL);
} else if ((errno == ERANGE) || isinf(value)) {
if (value == 0.0) {
s = "floating-point value too small to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *)NULL);
} else {
s = "floating-point value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *)NULL);
}
} else {
Tcl_Obj *objPtr = Tcl_ObjPrintf(
"unknown floating-point error, errno = %d", errno);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
TclGetString(objPtr), (char *)NULL);
Tcl_SetObjResult(interp, objPtr);
}
}
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
9759 9760 9761 9762 9763 9764 9765 |
strBytesSharedOnce = 0.0;
for (ui = 0; ui < globalTablePtr->numBuckets; ui++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
| | | 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 |
strBytesSharedOnce = 0.0;
for (ui = 0; ui < globalTablePtr->numBuckets; ui++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
(void) TclGetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
if (entryPtr->refCount > 1) {
numSharedMultX++;
strBytesSharedMultX += (length+1);
} else {
|
| ︙ | ︙ | |||
9837 9838 9839 9840 9841 9842 9843 |
statsPtr->currentByteCodeBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n",
currentHeaderBytes,
Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes),
currentHeaderBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n",
statsPtr->currentInstBytes,
| | | | | | | 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 |
statsPtr->currentByteCodeBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n",
currentHeaderBytes,
Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes),
currentHeaderBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n",
statsPtr->currentInstBytes,
Percent(statsPtr->currentInstBytes, statsPtr->currentByteCodeBytes),
statsPtr->currentInstBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
statsPtr->currentLitBytes,
Percent(statsPtr->currentLitBytes, statsPtr->currentByteCodeBytes),
statsPtr->currentLitBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n",
statsPtr->currentExceptBytes,
Percent(statsPtr->currentExceptBytes, statsPtr->currentByteCodeBytes),
statsPtr->currentExceptBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
statsPtr->currentAuxBytes,
Percent(statsPtr->currentAuxBytes, statsPtr->currentByteCodeBytes),
statsPtr->currentAuxBytes / numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n",
statsPtr->currentCmdMapBytes,
Percent(statsPtr->currentCmdMapBytes, statsPtr->currentByteCodeBytes),
statsPtr->currentCmdMapBytes / numCurrentByteCodes);
/*
* Detailed literal statistics.
*/
Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
|
| ︙ | ︙ | |||
9985 9986 9987 9988 9989 9990 9991 |
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
if (objc == 1) {
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
| | | 9973 9974 9975 9976 9977 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 |
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
if (objc == 1) {
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
char *str = TclGetStringFromObj(objv[1], &length);
if (length) {
if (strcmp(str, "stdout") == 0) {
outChan = Tcl_GetStdChannel(TCL_STDOUT);
} else if (strcmp(str, "stderr") == 0) {
outChan = Tcl_GetStdChannel(TCL_STDERR);
} else {
|
| ︙ | ︙ |
Changes to generic/tclFCmd.c.
| ︙ | ︙ | |||
914 915 916 917 918 919 920 |
Tcl_Obj *splitPtr;
Tcl_Obj *resultPtr = NULL;
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
Tcl_IncrRefCount(splitPtr);
if (objc != 0) {
| | | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
Tcl_Obj *splitPtr;
Tcl_Obj *resultPtr = NULL;
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
Tcl_IncrRefCount(splitPtr);
if (objc != 0) {
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
if (objc > 0) {
Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
if ((objc == 1) &&
(Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
|
| ︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 | Tcl_IncrRefCount(objStrings); /* * Use objStrings as a list object. */ | | | 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
Tcl_IncrRefCount(objStrings);
/*
* Use objStrings as a list object.
*/
if (TclListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStringsAllocated = (const char **)
TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *));
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
attributeStringsAllocated[index] = TclGetString(objPtr);
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 |
int index;
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
| | | 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 |
int index;
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (char *)NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
|
| ︙ | ︙ | |||
1135 1136 1137 1138 1139 1140 1141 |
int i, index;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
| | | | 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 |
int i, index;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (char *)NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
"NOVALUE", (char *)NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
objv[i + 1]) != TCL_OK) {
goto end;
}
}
|
| ︙ | ︙ | |||
1243 1244 1245 1246 1247 1248 1249 |
}
} else {
linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK;
}
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
| | | | | | | | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 |
}
} else {
linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK;
}
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]),
TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringFree(&ds);
/*
* Create link from source to target.
*/
contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
if (contents == NULL) {
|
| ︙ | ︙ | |||
1306 1307 1308 1309 1310 1311 1312 |
}
return TCL_ERROR;
}
} else {
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
| | | | | | | | 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 |
}
return TCL_ERROR;
}
} else {
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]),
TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringFree(&ds);
/*
* Read link
*/
contents = Tcl_FSLink(objv[index], NULL, 0);
if (contents == NULL) {
|
| ︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 |
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[2];
| | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 |
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[2];
const char *string = TclGetStringFromObj(templateObj, &length);
/*
* Treat an empty string as if it wasn't there.
*/
if (length == 0) {
goto makeTemporary;
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 |
Tcl_WrongNumArgs(interp, 1, objv, "?template?");
return TCL_ERROR;
}
if (objc > 1) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[1];
| | | 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 |
Tcl_WrongNumArgs(interp, 1, objv, "?template?");
return TCL_ERROR;
}
if (objc > 1) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[1];
const char *string = TclGetStringFromObj(templateObj, &length);
const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
/*
* Treat an empty string as if it wasn't there.
*/
if (length == 0) {
|
| ︙ | ︙ |
Changes to generic/tclFileName.c.
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
Tcl_DString *resultPtr, /* Buffer to hold result. */
int offset, /* Offset in buffer where result should be
* stored. */
Tcl_PathType *typePtr) /* Where to store pathType result */
{
int extended = 0;
| | | | | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
Tcl_DString *resultPtr, /* Buffer to hold result. */
int offset, /* Offset in buffer where result should be
* stored. */
Tcl_PathType *typePtr) /* Where to store pathType result */
{
int extended = 0;
if ( (path[0] == '/' || path[0] == '\\')
&& (path[1] == '/' || path[1] == '\\')
&& (path[2] == '?')
&& (path[3] == '/' || path[3] == '\\')) {
extended = 1;
path = path + 4;
if (path[0] == 'U' && path[1] == 'N' && path[2] == 'C'
&& (path[3] == '/' || path[3] == '\\')) {
extended = 2;
path = path + 4;
}
}
if (path[0] == '/' || path[0] == '\\') {
/*
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
const char *path = TclGetString(pathPtr);
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
const char *path = TclGetString(pathPtr);
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
const char *origPath = path;
/*
* Paths that begin with / are absolute.
*/
if (path[0] == '/') {
++path;
/*
* Check for "//" network path prefix
*/
if ((*path == '/') && path[1] && (path[1] != '/')) {
path += 2;
while (*path && *path != '/') {
++path;
}
}
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the "//" code was used.
*/
*driveNameLengthPtr = (path - origPath);
}
} else {
type = TCL_PATH_RELATIVE;
}
break;
}
case TCL_PLATFORM_WINDOWS: {
Tcl_DString ds;
const char *rootEnd;
Tcl_DStringInit(&ds);
rootEnd = ExtractWinRoot(path, &ds, 0, &type);
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
*driveNameRef = Tcl_DStringToObj(&ds);
Tcl_IncrRefCount(*driveNameRef);
}
}
Tcl_DStringFree(&ds);
break;
}
}
return type;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
}
/*
* Compute the number of elements in the result.
*/
if (lenPtr != NULL) {
| | | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
}
/*
* Compute the number of elements in the result.
*/
if (lenPtr != NULL) {
TclListObjLength(NULL, resultPtr, lenPtr);
}
return resultPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
/*
* Calculate space required for the result.
*/
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
| | | | | 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 |
/*
* Calculate space required for the result.
*/
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
(void)TclGetStringFromObj(eltPtr, &len);
size += len + 1;
}
/*
* Allocate a buffer large enough to hold the contents of all of the list
* plus the argv pointers and the terminating NULL pointer.
*/
*argvPtr = (const char **)Tcl_Alloc(
((((*argcPtr) + 1) * sizeof(char *)) + size));
/*
* Position p after the last argv pointer and copy the contents of the
* list in, piece by piece.
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
str = TclGetStringFromObj(eltPtr, &len);
memcpy(p, str, len + 1);
p += len+1;
}
/*
* Now set up the argv pointers.
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
(*argvPtr)[i] = p;
while (*(p++) != '\0');
}
(*argvPtr)[i] = NULL;
/*
* Free the result ptr given to us by Tcl_FSSplitPath
*/
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
elementStart = path;
while ((*path != '\0') && (*path != '/')) {
path++;
}
length = path - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
| | | | 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
elementStart = path;
while ((*path != '\0') && (*path != '/')) {
path++;
}
length = path - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
nextElt = Tcl_NewStringObj(elementStart, length);
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*path++ == '\0') {
break;
}
}
return result;
}
|
| ︙ | ︙ | |||
808 809 810 811 812 813 814 |
{
int needsSep;
Tcl_Size length;
char *dest;
const char *p;
const char *start;
| | | | | | 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 |
{
int needsSep;
Tcl_Size length;
char *dest;
const char *p;
const char *start;
start = TclGetStringFromObj(prefix, &length);
/*
* Remove the ./ from drive-letter prefixed
* elements on Windows, unless it is the first component.
*/
p = joining;
if (length != 0) {
if ((p[0] == '.') && (p[1] == '/') &&
(tclPlatform==TCL_PLATFORM_WINDOWS) && isalpha(UCHAR(p[2]))
&& (p[3] == ':')) {
p += 2;
}
}
if (*p == '\0') {
return;
}
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
(void)TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
/*
* Check to see if we need to append a separator.
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
| | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
/*
* Check to see if we need to append a separator.
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
(void)TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
Tcl_IncrRefCount(resultObj);
Tcl_DecrRefCount(listObj);
/*
* Store the result.
*/
| | | 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 |
Tcl_IncrRefCount(resultObj);
Tcl_DecrRefCount(listObj);
/*
* Store the result.
*/
resultStr = TclGetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
/*
* Return a pointer to the result.
*/
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 |
* Keep accepting as a no-op option to accommodate old scripts.
*/
break;
case GLOB_DIR: /* -dir */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-directory\"", -1));
| | | | | | | | | | | 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 |
* Keep accepting as a no-op option to accommodate old scripts.
*/
break;
case GLOB_DIR: /* -dir */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-directory\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
dir == PATH_DIR
? "\"-directory\" may only be used once"
: "\"-directory\" cannot be used with \"-path\"",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", (char *)NULL);
return TCL_ERROR;
}
dir = PATH_DIR;
globFlags |= TCL_GLOBMODE_DIR;
pathOrDir = objv[i+1];
i++;
break;
case GLOB_JOIN: /* -join */
join = 1;
break;
case GLOB_TAILS: /* -tails */
globFlags |= TCL_GLOBMODE_TAILS;
break;
case GLOB_PATH: /* -path */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
dir == PATH_GENERAL
? "\"-path\" may only be used once"
: "\"-path\" cannot be used with \"-dictionary\"",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", (char *)NULL);
return TCL_ERROR;
}
dir = PATH_GENERAL;
pathOrDir = objv[i+1];
i++;
break;
case GLOB_TYPE: /* -types */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL);
return TCL_ERROR;
}
typePtr = objv[i+1];
if (TclListObjLength(interp, typePtr, &length) != TCL_OK) {
return TCL_ERROR;
}
i++;
break;
case GLOB_LAST: /* -- */
i++;
goto endOfForLoop;
}
}
endOfForLoop:
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", (char *)NULL);
return TCL_ERROR;
}
separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
}
if (dir == PATH_GENERAL) {
Tcl_Size pathlength;
const char *last;
const char *first = TclGetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
*/
last = first + pathlength;
for (; last != first; last--) {
if (strchr(separators, last[-1]) != NULL) {
break;
}
}
if (last == first + pathlength) {
/*
* It's really a directory.
|
| ︙ | ︙ | |||
1347 1348 1349 1350 1351 1352 1353 |
if (typePtr != NULL) {
/*
* The rest of the possible type arguments (except 'd') are platform
* specific. We don't complain when they are used on an incompatible
* platform.
*/
| | | | 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 |
if (typePtr != NULL) {
/*
* The rest of the possible type arguments (except 'd') are platform
* specific. We don't complain when they are used on an incompatible
* platform.
*/
TclListObjLength(interp, typePtr, &length);
if (length == 0) {
goto skipTypes;
}
globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
globTypes->macCreator = NULL;
while (length-- > 0) {
Tcl_Size len;
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = TclGetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
} else if (len == 1) {
switch (str[0]) {
case 'r':
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 |
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
Tcl_Size llen;
| | | 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 |
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
Tcl_Size llen;
if ((TclListObjLength(NULL, look, &llen) == TCL_OK)
&& (llen == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", TclGetString(item))) {
Tcl_ListObjIndex(interp, look, 1, &item);
if (!strcmp("type", TclGetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macType != NULL) {
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 | * haven't yet made use of it. */ badTypesArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", TclGetString(look))); | | | | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
* haven't yet made use of it.
*/
badTypesArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument to \"-types\": %s",
TclGetString(look)));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (char *)NULL);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
badMacTypesArg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"only one MacOS type or creator argument"
" to \"-types\" allowed", -1));
result = TCL_ERROR;
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (char *)NULL);
join = 0;
goto endOfGlob;
}
}
}
skipTypes:
|
| ︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 |
* If this length has never been set, set it here.
*/
if (pathPrefix == NULL) {
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
| | | | | 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 |
* If this length has never been set, set it here.
*/
if (pathPrefix == NULL) {
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
pre = TclGetStringFromObj(pathPrefix, &prefixLen);
if (prefixLen > 0
&& (strchr(separators, pre[prefixLen-1]) == NULL)) {
/*
* If we're on Windows and the prefix is a volume relative one
* like 'C:', then there won't be a path separator in between, so
* no need to skip it here.
*/
if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2)
|| (pre[1] != ':')) {
prefixLen++;
}
}
TclListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
Tcl_Size len;
const char *oldStr = TclGetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
TclNewLiteralStringObj(elem, ".");
} else {
|
| ︙ | ︙ | |||
2033 2034 2035 2036 2037 2038 2039 | closeBrace = p; break; } Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched open-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", | | | | 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 |
closeBrace = p;
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched open-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
(char *)NULL);
return TCL_ERROR;
} else if (*p == '}') {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched close-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
(char *)NULL);
return TCL_ERROR;
}
}
/*
* Substitute the alternate patterns from the braces and recurse.
*/
|
| ︙ | ︙ | |||
2148 2149 2150 2151 2152 2153 2154 |
result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
pattern, &dirOnly);
*p = save;
if (result == TCL_OK) {
Tcl_Size i, subdirc, repair = -1;
Tcl_Obj **subdirv;
| | | | | 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 |
result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
pattern, &dirOnly);
*p = save;
if (result == TCL_OK) {
Tcl_Size i, subdirc, repair = -1;
Tcl_Obj **subdirv;
result = TclListObjGetElements(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
result = DoGlob(interp, matchesObj, separators, subdirv[i],
1, p+1, types);
if (copy) {
Tcl_Size end;
Tcl_DecrRefCount(subdirv[i]);
subdirv[i] = copy;
TclListObjLength(NULL, matchesObj, &end);
while (repair < end) {
const char *bytes;
Tcl_Size numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
bytes = TclGetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
repair++;
}
repair = TCL_INDEX_NONE;
}
|
| ︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 |
* approach).
*/
Tcl_DStringInit(&append);
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
| | | 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 |
* approach).
*/
Tcl_DStringInit(&append);
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
(void) TclGetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
switch (tclPlatform) {
case TCL_PLATFORM_WINDOWS:
if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
|
| ︙ | ︙ | |||
2251 2252 2253 2254 2255 2256 2257 |
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
Tcl_Size len;
| | | 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 |
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
Tcl_Size len;
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
Tcl_DStringLength(&append));
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 | * volume-relative path. In particular globbing in Windows shares, * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ Tcl_Size len; | | | 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 |
* volume-relative path. In particular globbing in Windows shares,
* when not using -dir or -path, e.g. 'glob [file join
* //machine/share/subdir *]' requires adding a separator here.
* This behaviour is not currently tested for in the test suite.
*/
Tcl_Size len;
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
}
|
| ︙ | ︙ |
Changes to generic/tclGetDate.y.
1 2 3 4 5 6 7 8 9 | /* * tclGetDate.y -- * * Contains yacc grammar for parsing date and time strings. The output of * this file should be the file tclDate.c which is used directly in the * Tcl sources. Note that this file is largely obsolete in Tcl 8.5; it is * only used when doing free-form date parsing, an ill-defined process * anyway. * | | | > | | > | | > > | < < < | | < < > < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > > > > > > > | | | | | < < | | | > | > > > | | > > | > > > | | | | | | | < > | < < | > > > > > > > > > > > | < < < | < < < < < < < < > > > > > > > > | > > > > | | | | > > > > | | > > > > > > | < < < < < < < < < | | 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 |
/*
* tclGetDate.y --
*
* Contains yacc grammar for parsing date and time strings. The output of
* this file should be the file tclDate.c which is used directly in the
* Tcl sources. Note that this file is largely obsolete in Tcl 8.5; it is
* only used when doing free-form date parsing, an ill-defined process
* anyway.
*
* Copyright © 1992-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright © 1995-1997 Sun Microsystems, Inc.
* Copyright © 2015 Sergey G. Brester aka sebres.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
%parse-param {DateInfo* info}
%lex-param {DateInfo* info}
%define api.pure
/* %error-verbose would be nice, but our token names are meaningless */
%locations
%{
/*
* tclDate.c --
*
* This file is generated from a yacc grammar defined in the file
* tclGetDate.y. It should not be edited directly.
*
* Copyright © 1992-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright © 1995-1997 Sun Microsystems, Inc.
* Copyright © 2015 Sergey G. Brester aka sebres.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
*/
#include "tclInt.h"
/*
* Bison generates several labels that happen to be unused. Several compilers
* don't like that, and complain. Simply disable the warning to silence them.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#elif defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic ignored "-Wunused-but-set-variable"
#endif
#if 0
#define YYDEBUG 1
#endif
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
#include "tclDate.h"
#define YYMALLOC Tcl_Alloc
#define YYFREE(x) (Tcl_Free((void*) (x)))
#define EPOCH 1970
#define START_OF_TIME 1902
#define END_OF_TIME 2037
/*
* The offset of tm_year of struct tm returned by localtime, gmtime, etc.
* Posix requires 1900.
*/
#define TM_YEAR_BASE 1900
#define HOUR(x) ((60 * (int)(x)))
#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0))
#define yyIncrFlags(f) \
do { \
info->errFlags |= (info->flags & (f)); \
if (info->errFlags) { YYABORT; } \
info->flags |= (f); \
} while (0);
/*
* An entry in the lexical lookup table.
*/
typedef struct {
const char *name;
int type;
int value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
%}
%union {
Tcl_WideInt Number;
enum _MERIDIAN Meridian;
}
%{
/*
* Prototypes of internal functions.
*/
static int LookupWord(YYSTYPE* yylvalPtr, char *buff);
static void TclDateerror(YYLTYPE* location,
DateInfo* info, const char *s);
static int TclDatelex(YYSTYPE* yylvalPtr, YYLTYPE* location,
DateInfo* info);
MODULE_SCOPE int yyparse(DateInfo*);
%}
%token tAGO
%token tDAY
%token tDAYZONE
%token tID
%token tMERIDIAN
%token tMONTH
%token tMONTH_UNIT
%token tSTARDATE
%token tSEC_UNIT
%token tUNUMBER
%token tZONE
%token tZONEwO4
%token tZONEwO2
%token tEPOCH
%token tDST
%token tISOBAS8
%token tISOBAS6
%token tISOBASL
%token tDAY_UNIT
%token tNEXT
%token SP
%type <Number> tDAY
%type <Number> tDAYZONE
%type <Number> tMONTH
%type <Number> tMONTH_UNIT
%type <Number> tDST
%type <Number> tSEC_UNIT
%type <Number> tUNUMBER
%type <Number> INTNUM
%type <Number> tZONE
%type <Number> tZONEwO4
%type <Number> tZONEwO2
%type <Number> tISOBAS8
%type <Number> tISOBAS6
%type <Number> tISOBASL
%type <Number> tDAY_UNIT
%type <Number> unit
%type <Number> sign
%type <Number> tNEXT
%type <Number> tSTARDATE
%type <Meridian> tMERIDIAN
%type <Meridian> o_merid
%%
spec : /* NULL */
| spec item
/* | spec SP item */
;
item : time {
yyIncrFlags(CLF_TIME);
}
| zone {
yyIncrFlags(CLF_ZONE);
}
| date {
yyIncrFlags(CLF_HAVEDATE);
}
| ordMonth {
yyIncrFlags(CLF_ORDINALMONTH);
}
| day {
yyIncrFlags(CLF_DAYOFWEEK);
}
| relspec {
info->flags |= CLF_RELCONV;
}
| iso {
yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
}
| trek {
yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
info->flags |= CLF_RELCONV;
}
| numitem
;
iextime : tUNUMBER ':' tUNUMBER ':' tUNUMBER {
yyHour = $1;
yyMinutes = $3;
yySeconds = $5;
}
| tUNUMBER ':' tUNUMBER {
yyHour = $1;
yyMinutes = $3;
yySeconds = 0;
}
;
time : tUNUMBER tMERIDIAN {
yyHour = $1;
yyMinutes = 0;
yySeconds = 0;
yyMeridian = $2;
}
| iextime o_merid {
yyMeridian = $2;
}
;
zone : tZONE tDST {
yyTimezone = $1;
yyDSTmode = DSTon;
}
| tZONE {
yyTimezone = $1;
yyDSTmode = DSToff;
}
| tDAYZONE {
yyTimezone = $1;
yyDSTmode = DSTon;
}
| tZONEwO4 sign INTNUM { /* GMT+0100, GMT-1000, etc. */
yyTimezone = $1 - $2*($3 % 100 + ($3 / 100) * 60);
yyDSTmode = DSToff;
}
| tZONEwO2 sign INTNUM { /* GMT+1, GMT-10, etc. */
yyTimezone = $1 - $2*($3 * 60);
yyDSTmode = DSToff;
}
| sign INTNUM { /* +0100, -0100 */
yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60);
yyDSTmode = DSToff;
}
;
comma : ','
| ',' SP
;
day : tDAY {
yyDayOrdinal = 1;
yyDayOfWeek = $1;
}
| tDAY comma {
yyDayOrdinal = 1;
yyDayOfWeek = $1;
}
| tUNUMBER tDAY {
yyDayOrdinal = $1;
yyDayOfWeek = $2;
}
| sign SP tUNUMBER tDAY {
yyDayOrdinal = $1 * $3;
yyDayOfWeek = $4;
}
| sign tUNUMBER tDAY {
yyDayOrdinal = $1 * $2;
yyDayOfWeek = $3;
}
| tNEXT tDAY {
yyDayOrdinal = 2;
yyDayOfWeek = $2;
}
;
iexdate : tUNUMBER '-' tUNUMBER '-' tUNUMBER {
yyMonth = $3;
yyDay = $5;
yyYear = $1;
}
;
date : tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
}
| tUNUMBER '/' tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
yyYear = $5;
}
| isodate
| tUNUMBER '-' tMONTH '-' tUNUMBER {
yyDay = $1;
yyMonth = $3;
yyYear = $5;
}
| tMONTH tUNUMBER {
yyMonth = $1;
yyDay = $2;
}
| tMONTH tUNUMBER comma tUNUMBER {
yyMonth = $1;
yyDay = $2;
yyYear = $4;
}
| tUNUMBER tMONTH {
yyMonth = $2;
yyDay = $1;
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
yyMonth = $2;
yyDay = $1;
yyYear = $3;
}
;
ordMonth: tNEXT tMONTH {
| | | | | | < > | | | | < < < | < < < < > > | < < < < | | | > > > | > > > > > > > > > | | | > > > | | | 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 |
yyMonth = $2;
yyDay = $1;
yyYear = $3;
}
;
ordMonth: tNEXT tMONTH {
yyMonthOrdinalIncr = 1;
yyMonthOrdinal = $2;
}
| tNEXT tUNUMBER tMONTH {
yyMonthOrdinalIncr = $2;
yyMonthOrdinal = $3;
}
;
isosep : 'T'|SP
;
isodate : tISOBAS8 { /* YYYYMMDD */
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
}
| tISOBAS6 { /* YYMMDD */
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
}
| iexdate
;
isotime : tISOBAS6 {
yyHour = $1 / 10000;
yyMinutes = ($1 % 10000)/100;
yySeconds = $1 % 100;
}
| iextime
;
iso : isodate isosep isotime
| tISOBASL tISOBAS6 { /* YYYYMMDDhhmmss */
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $2 / 10000;
yyMinutes = ($2 % 10000)/100;
yySeconds = $2 % 100;
}
| tISOBASL tUNUMBER { /* YYYYMMDDhhmm */
if (yyDigitCount != 4) YYABORT; /* normally unreached */
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $2 / 100;
yyMinutes = ($2 % 100);
yySeconds = 0;
}
;
trek : tSTARDATE INTNUM '.' tUNUMBER {
/*
* Offset computed year by -377 so that the returned years will be
* in a range accessible with a 32 bit clock seconds value.
*/
yyYear = $2/1000 + 2323 - 377;
yyDay = 1;
yyMonth = 1;
yyRelDay += (($2%1000)*(365 + IsLeapYear(yyYear)))/1000;
yyRelSeconds += $4 * (144LL * 60LL);
}
;
relspec : relunits tAGO {
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
}
| relunits
;
relunits : sign SP INTNUM unit {
*yyRelPointer += $1 * $3 * $4;
}
| sign INTNUM unit {
*yyRelPointer += $1 * $2 * $3;
}
| INTNUM unit {
*yyRelPointer += $1 * $2;
}
| tNEXT unit {
*yyRelPointer += $2;
}
| tNEXT INTNUM unit {
*yyRelPointer += $2 * $3;
}
| unit {
*yyRelPointer += $1;
}
;
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
}
| tMONTH_UNIT {
$$ = $1;
yyRelPointer = &yyRelMonth;
}
;
| | > > > > > > > > > | > > | | 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 |
}
| tMONTH_UNIT {
$$ = $1;
yyRelPointer = &yyRelMonth;
}
;
INTNUM : tUNUMBER {
$$ = $1;
}
| tISOBAS6 {
$$ = $1;
}
| tISOBAS8 {
$$ = $1;
}
;
numitem : tUNUMBER {
if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_RELCONV)) == (CLF_TIME|CLF_HAVEDATE)) {
yyYear = $1;
} else {
yyIncrFlags(CLF_TIME);
if (yyDigitCount <= 2) {
yyHour = $1;
yyMinutes = 0;
} else {
yyHour = $1 / 100;
yyMinutes = $1 % 100;
}
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 |
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
| | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
{ "sunday", tDAY, 7 },
{ "monday", tDAY, 1 },
{ "tuesday", tDAY, 2 },
{ "tues", tDAY, 2 },
{ "wednesday", tDAY, 3 },
{ "wednes", tDAY, 3 },
{ "thursday", tDAY, 4 },
{ "thur", tDAY, 4 },
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
| < < < < < < < < < < < < < < | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0 },
{ NULL, 0, 0 }
};
/*
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
| > > | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "akst", tZONE, HOUR( 9) }, /* Alaska Standard */
{ "akdt", tDAYZONE, HOUR( 9) }, /* Alaska Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > | | | | < < < < < < | < | < < < | < < | | | 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 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) },
{ "b", tZONE, -HOUR( 2) },
{ "c", tZONE, -HOUR( 3) },
{ "d", tZONE, -HOUR( 4) },
{ "e", tZONE, -HOUR( 5) },
{ "f", tZONE, -HOUR( 6) },
{ "g", tZONE, -HOUR( 7) },
{ "h", tZONE, -HOUR( 8) },
{ "i", tZONE, -HOUR( 9) },
{ "k", tZONE, -HOUR(10) },
{ "l", tZONE, -HOUR(11) },
{ "m", tZONE, -HOUR(12) },
{ "n", tZONE, HOUR( 1) },
{ "o", tZONE, HOUR( 2) },
{ "p", tZONE, HOUR( 3) },
{ "q", tZONE, HOUR( 4) },
{ "r", tZONE, HOUR( 5) },
{ "s", tZONE, HOUR( 6) },
{ "t", tZONE, HOUR( 7) },
{ "u", tZONE, HOUR( 8) },
{ "v", tZONE, HOUR( 9) },
{ "w", tZONE, HOUR( 10) },
{ "x", tZONE, HOUR( 11) },
{ "y", tZONE, HOUR( 12) },
{ "z", tZONE, HOUR( 0) },
{ NULL, 0, 0 }
};
static inline const char *
bypassSpaces(
const char *s)
{
while (TclIsSpaceProc(*s)) {
s++;
}
return s;
}
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
if (!infoPtr->messages) {
TclNewObj(infoPtr->messages);
}
Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1);
Tcl_AppendToObj(infoPtr->messages, s, -1);
Tcl_AppendToObj(infoPtr->messages, " (characters ", -1);
TclNewIntObj(t, location->first_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, "-", -1);
TclNewIntObj(t, location->last_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
int
ToSeconds(
int Hours,
int Minutes,
int Seconds,
MERIDIAN Meridian)
{
switch (Meridian) {
case MER24:
return (Hours * 60 + Minutes) * 60 + Seconds;
case MERam:
return (((Hours / 24) * 24 + (Hours % 12)) * 60 + Minutes) * 60 + Seconds;
case MERpm:
return (((Hours / 24) * 24 + (Hours % 12) + 12) * 60 + Minutes) * 60 + Seconds;
}
return -1; /* Should never be reached */
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
char *p;
char *q;
const TABLE *tp;
int i, abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
if (*buff == 'a' && (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0)) {
yylvalPtr->Meridian = MERam;
return tMERIDIAN;
}
if (*buff == 'p' && (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0)) {
yylvalPtr->Meridian = MERpm;
return tMERIDIAN;
}
/*
* See if we have an abbreviation for a month.
*/
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 896 897 898 |
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| > | > > > | > > | | > > > | | > | > | > > > > > | | < > | > | > > > > | > > > | > < < | > > | < > | | | | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < | < < < < < | | | | | | | < | | < < < < < < | < < < | < | | < > | < < < < | | > > > > > > > > > > > > > > > > | > | | > | < | | < | | > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 |
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
const char *tokStart;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
if (isspace(UCHAR(*yyInput))) {
yyInput = bypassSpaces(yyInput);
/* ignore space at end of text and before some words */
c = *yyInput;
if (c != '\0' && !isalpha(UCHAR(c))) {
return SP;
}
}
tokStart = yyInput;
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Count the number of digits.
*/
p = (char *)yyInput;
while (isdigit(UCHAR(*++p))) {};
yyDigitCount = p - yyInput;
/*
* A number with 12 or 14 digits is considered an ISO 8601 date.
*/
if (yyDigitCount == 14 || yyDigitCount == 12) {
/* long form of ISO 8601 (without separator), either
* YYYYMMDDhhmmss or YYYYMMDDhhmm, so reduce to date
* (8 chars is isodate) */
p = (char *)yyInput+8;
if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
return tID; /* overflow*/
}
yyDigitCount = 8;
yyInput = p;
location->last_column = yyInput - info->dateStart - 1;
return tISOBASL;
}
/*
* Convert the string into a number
*/
if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
return tID; /* overflow*/
}
yyInput = p;
/*
* A number with 6 or more digits is considered an ISO 8601 base.
*/
location->last_column = yyInput - info->dateStart - 1;
if (yyDigitCount >= 6) {
if (yyDigitCount == 8) {
return tISOBAS8;
}
if (yyDigitCount == 6) {
return tISOBAS6;
}
}
/* ignore spaces after digits (optional) */
yyInput = bypassSpaces(yyInput);
return tUNUMBER;
}
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
int ret;
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
if (p < &buff[sizeof(buff) - 1]) {
*p++ = c;
}
}
*p = '\0';
yyInput--;
location->last_column = yyInput - info->dateStart - 1;
ret = LookupWord(yylvalPtr, buff);
/*
* lookahead:
* for spaces to consider word boundaries (for instance
* literal T in isodateTisotimeZ is not a TZ, but Z is UTC);
* for +/- digit, to differentiate between "GMT+1000 day" and "GMT +1000 day";
* bypass spaces after token (but ignore by TZ+OFFS), because should
* recognize next SP token, if TZ only.
*/
if (ret == tZONE || ret == tDAYZONE) {
c = *yyInput;
if (isdigit(UCHAR(c))) { /* literal not a TZ */
yyInput = tokStart;
return *yyInput++;
}
if ((c == '+' || c == '-') && isdigit(UCHAR(*(yyInput+1)))) {
if ( !isdigit(UCHAR(*(yyInput+2)))
|| !isdigit(UCHAR(*(yyInput+3)))) {
/* GMT+1, GMT-10, etc. */
return tZONEwO2;
}
if ( isdigit(UCHAR(*(yyInput+4)))
&& !isdigit(UCHAR(*(yyInput+5)))) {
/* GMT+1000, etc. */
return tZONEwO4;
}
}
}
yyInput = bypassSpaces(yyInput);
return ret;
}
if (c != '(') {
location->last_column = yyInput - info->dateStart;
return *yyInput++;
}
Count = 0;
do {
c = *yyInput++;
if (c == '\0') {
location->last_column = yyInput - info->dateStart - 1;
return c;
} else if (c == '(') {
Count++;
} else if (c == ')') {
Count--;
}
} while (Count > 0);
}
}
int
TclClockFreeScan(
Tcl_Interp *interp, /* Tcl interpreter */
DateInfo *info) /* Input and result parameters */
{
int status;
#if YYDEBUG
/* enable debugging if compiled with YYDEBUG */
yydebug = 1;
#endif
/*
* yyInput = stringToParse;
*
* ClockInitDateInfo(info) should be executed to pre-init info;
*/
yyDSTmode = DSTmaybe;
info->separatrix = "";
info->dateStart = yyInput;
/* ignore spaces at begin */
yyInput = bypassSpaces(yyInput);
/* parse */
status = yyparse(info);
if (status == 1) {
const char *msg = NULL;
if (info->errFlags & CLF_HAVEDATE) {
msg = "more than one date in string";
} else if (info->errFlags & CLF_TIME) {
msg = "more than one time of day in string";
} else if (info->errFlags & CLF_ZONE) {
msg = "more than one time zone in string";
} else if (info->errFlags & CLF_DAYOFWEEK) {
msg = "more than one weekday in string";
} else if (info->errFlags & CLF_ORDINALMONTH) {
msg = "more than one ordinal month in string";
}
if (msg) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
} else {
Tcl_SetObjResult(interp,
info->messages ? info->messages : Tcl_NewObj());
info->messages = NULL;
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL);
}
status = TCL_ERROR;
} else if (status == 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
status = TCL_ERROR;
} else if (status != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
"from date parser. Please "
"report this error as a "
"bug in Tcl.", -1));
Tcl_SetErrorCode(interp, "TCL", "BUG", (char *)NULL);
status = TCL_ERROR;
}
if (info->messages) {
Tcl_DecrRefCount(info->messages);
}
return status;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclHash.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | /* * Prototypes for the array hash key methods. */ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); | | < < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | /* * Prototypes for the array hash key methods. */ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); static size_t HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the string hash key methods. */ static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: */ static Tcl_HashEntry * BogusFind(Tcl_HashTable *tablePtr, const char *key); static Tcl_HashEntry * BogusCreate(Tcl_HashTable *tablePtr, const char *key, |
| ︙ | ︙ | |||
76 77 78 79 80 81 82 |
NULL, /* AllocOneWordKey, */ /* allocEntryProc */
NULL /* FreeOneWordKey, */ /* freeEntryProc */
};
const Tcl_HashKeyType tclStringHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
| | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
NULL, /* AllocOneWordKey, */ /* allocEntryProc */
NULL /* FreeOneWordKey, */ /* freeEntryProc */
};
const Tcl_HashKeyType tclStringHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
TclHashStringKey, /* hashKeyProc */
TclCompareStringKeys, /* compareKeysProc */
AllocStringEntry, /* allocEntryProc */
NULL /* freeEntryProc */
};
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
static Tcl_HashEntry *
FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key) /* Key to use to find matching entry. */
{
return CreateHashEntry(tablePtr, key, NULL);
}
| < | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
static Tcl_HashEntry *
FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key) /* Key to use to find matching entry. */
{
return CreateHashEntry(tablePtr, key, NULL);
}
/*
*----------------------------------------------------------------------
*
* CreateHashEntry --
*
* Given a hash table with string keys, and a string key, find the entry
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
| | | | | | | | | | | > > > > > > > > > > > > > > | | | | > | 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 |
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
if (typePtr->flags & TCL_HASH_KEY_DIRECT_COMPARE) {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != hPtr->hash) {
continue;
}
/* if keys pointers or values are equal */
if ((key == hPtr->key.oneWordValue)
|| compareKeysProc((void *) key, hPtr)) {
if (newPtr) {
*newPtr = 0;
}
return hPtr;
}
}
} else { /* no direct compare - compare key addresses only */
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != hPtr->hash) {
continue;
}
/* if needle pointer equals content pointer or values equal */
if ((key == hPtr->key.string)
|| compareKeysProc((void *) key, hPtr)) {
if (newPtr) {
*newPtr = 0;
}
return hPtr;
}
}
}
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != hPtr->hash) {
continue;
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 | * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry( | | < | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_NextHashEntry(
Tcl_HashSearch *searchPtr) /* Place to store information about progress
* through the table. Must have been
* initialized by calling
* Tcl_FirstHashEntry. */
{
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr = searchPtr->tablePtr;
|
| ︙ | ︙ | |||
653 654 655 656 657 658 659 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_HashEntry *hPtr;
size_t count = tablePtr->keyType * sizeof(int);
size_t size = offsetof(Tcl_HashEntry, key) + count;
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 | * None. * *---------------------------------------------------------------------- */ static int CompareArrayKeys( | | | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareArrayKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
size_t count = hPtr->tablePtr->keyType * sizeof(int);
return !memcmp(keyPtr, hPtr->key.string, count);
}
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
*
*----------------------------------------------------------------------
*/
static size_t
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 |
*
*----------------------------------------------------------------------
*/
static size_t
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
const int *array = (const int *) keyPtr;
size_t result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
count--, array++) {
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocStringEntry(
TCL_UNUSED(Tcl_HashTable *),
| | | | | | | | | | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocStringEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
const char *string = (const char *) keyPtr;
Tcl_HashEntry *hPtr;
size_t size, allocsize;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize);
memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize);
memcpy(hPtr->key.string, string, size);
Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* TclCompareStringKeys --
*
* Compares two string keys.
*
* Results:
* The return value is 0 if they are different and 1 if they are the
* same.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclCompareStringKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
return !strcmp((char *)keyPtr, hPtr->key.string);
}
/*
*----------------------------------------------------------------------
*
* TclHashStringKey --
*
* Compute a one-word summary of a text string, which can be used to
* generate a hash index.
*
* Results:
* The return value is a one-word summary of the information in string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclHashStringKey(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
const char *string = (const char *)keyPtr;
size_t result;
char c;
/*
* I tried a zillion different hash functions and asked many other people
|
| ︙ | ︙ |
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
*/
typedef struct ChannelHandler {
Channel *chanPtr; /* The channel structure for this channel. */
int mask; /* Mask of desired events. */
Tcl_ChannelProc *proc; /* Procedure to call in the type of
* Tcl_CreateChannelHandler. */
| | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
*/
typedef struct ChannelHandler {
Channel *chanPtr; /* The channel structure for this channel. */
int mask; /* Mask of desired events. */
Tcl_ChannelProc *proc; /* Procedure to call in the type of
* Tcl_CreateChannelHandler. */
void *clientData; /* Argument to pass to procedure. */
struct ChannelHandler *nextPtr;
/* Next one in list of registered handlers. */
} ChannelHandler;
/*
* This structure keeps track of the current ChannelHandler being invoked in
* the current invocation of Tcl_NotifyChannel. There is a potential
|
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
* nested invocations of Tcl_NotifyChannel and compare the handler being
* deleted against the NEXT handler to be invoked in that invocation; when it
* finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr
* field of the structure to the next handler.
*/
typedef struct NextChannelHandler {
| | > | | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
* nested invocations of Tcl_NotifyChannel and compare the handler being
* deleted against the NEXT handler to be invoked in that invocation; when it
* finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr
* field of the structure to the next handler.
*/
typedef struct NextChannelHandler {
ChannelHandler *nextHandlerPtr;
/* The next handler to be invoked in
* this invocation. */
struct NextChannelHandler *nestedHandlerPtr;
/* Next nested invocation of
* Tcl_NotifyChannel. */
} NextChannelHandler;
/*
* The following structure is used by Tcl_GetsObj() to encapsulates the
* state for a "gets" operation.
*/
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
* copy. Note that the data buffer for the copy will be appended to this
* structure.
*/
typedef struct CopyState {
struct Channel *readPtr; /* Pointer to input channel. */
struct Channel *writePtr; /* Pointer to output channel. */
int readFlags; /* Original read channel flags. */
int writeFlags; /* Original write channel flags. */
Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */
Tcl_WideInt total; /* Total bytes transferred (written). */
Tcl_Interp *interp; /* Interp that started the copy. */
Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
Tcl_Size bufSize; /* Size of appended buffer. */
| > | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
* copy. Note that the data buffer for the copy will be appended to this
* structure.
*/
typedef struct CopyState {
struct Channel *readPtr; /* Pointer to input channel. */
struct Channel *writePtr; /* Pointer to output channel. */
int refCount; /* Reference counter. */
int readFlags; /* Original read channel flags. */
int writeFlags; /* Original write channel flags. */
Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */
Tcl_WideInt total; /* Total bytes transferred (written). */
Tcl_Interp *interp; /* Interp that started the copy. */
Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
Tcl_Size bufSize; /* Size of appended buffer. */
char buffer[TCLFLEXARRAY]; /* Copy buffer, this must be the last
* field. */
} CopyState;
/*
* All static variables used in this file are collected into a single instance
* of the following structure. For multi-threaded implementations, there is
* one instance of this structure for each thread.
*
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
/*
* Structure to record a close callback. One such record exists for
* each close callback registered for a channel.
*/
typedef struct CloseCallback {
| | | | > < | | 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 |
/*
* Structure to record a close callback. One such record exists for
* each close callback registered for a channel.
*/
typedef struct CloseCallback {
Tcl_CloseProc *proc; /* The procedure to call. */
void *clientData; /* Arbitrary one-word data to pass
* to the callback. */
struct CloseCallback *nextPtr;
/* For chaining close callbacks. */
} CloseCallback;
/*
* Static functions in this file:
*/
static ChannelBuffer * AllocChannelBuffer(Tcl_Size length);
static void PreserveChannelBuffer(ChannelBuffer *bufPtr);
static void ReleaseChannelBuffer(ChannelBuffer *bufPtr);
static int IsShared(ChannelBuffer *bufPtr);
static void ChannelFree(Channel *chanPtr);
static void ChannelTimerProc(void *clientData);
static int ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int CheckChannelErrors(ChannelState *statePtr,
int direction);
static int CheckForDeadChannel(Tcl_Interp *interp,
ChannelState *statePtr);
static void CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void CleanupChannelHandlers(Tcl_Interp *interp,
Channel *chanPtr);
static int CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
int errorCode);
static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
int errorCode, int flags);
static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void CommonGetsCleanup(Channel *chanPtr);
static int CopyData(CopyState *csPtr, int mask);
static void DeleteTimerHandler(ChannelState *statePtr);
static int Lossless(ChannelState *inStatePtr,
ChannelState *outStatePtr, long long toRead);
static int MoveBytes(CopyState *csPtr);
static void MBCallback(CopyState *csPtr, Tcl_Obj *errObj);
static void MBError(CopyState *csPtr, int mask, int errorCode);
static int MBRead(CopyState *csPtr);
static int MBWrite(CopyState *csPtr);
|
| ︙ | ︙ | |||
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | int charsLeft, int *factorPtr); static void RecycleBuffer(ChannelState *statePtr, ChannelBuffer *bufPtr, int mustDiscard); static int StackSetBlockMode(Channel *chanPtr, int mode); static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr, int mode); static void StopCopy(CopyState *csPtr); static void TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static Tcl_Size Write(Channel *chanPtr, const char *src, Tcl_Size srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); | > | | | 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 | int charsLeft, int *factorPtr); static void RecycleBuffer(ChannelState *statePtr, ChannelBuffer *bufPtr, int mustDiscard); static int StackSetBlockMode(Channel *chanPtr, int mode); static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr, int mode); static void StopCopy(CopyState *csPtr); static void CopyDecrRefCount(CopyState *csPtr); static void TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static Tcl_Size Write(Channel *chanPtr, const char *src, Tcl_Size srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); static int WillRead(Channel *chanPtr); #define WriteChars(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, chanPtr->state->encoding) #define WriteBytes(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, tclIdentityEncoding) /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a * short description of what the macro does. * * -------------------------------------------------------------------------- * Tcl_Size BytesLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of data remaining in the buffer. * * Tcl_Size SpaceLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of space remaining at the end of the * buffer. * * int IsBufferReady(ChannelBuffer *bufPtr) * * Returns whether a buffer has bytes available within it. |
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
* a channel name in the context of an interp. Saves the lookup
* result and values needed to check its continued validity.
*/
typedef struct ResolvedChanName {
ChannelState *statePtr; /* The saved lookup result */
Tcl_Interp *interp; /* The interp in which the lookup was done. */
| | < < < | 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 |
* a channel name in the context of an interp. Saves the lookup
* result and values needed to check its continued validity.
*/
typedef struct ResolvedChanName {
ChannelState *statePtr; /* The saved lookup result */
Tcl_Interp *interp; /* The interp in which the lookup was done. */
Tcl_Size epoch; /* The epoch of the channel when the lookup
* was done. Use to verify validity. */
size_t refCount; /* Share this struct among many Tcl_Obj. */
} ResolvedChanName;
static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void FreeChannelInternalRep(Tcl_Obj *objPtr);
static const Tcl_ObjType chanObjType = {
"channel", /* name for this type */
FreeChannelInternalRep, /* freeIntRepProc */
DupChannelInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define ChanSetInternalRep(objPtr, resPtr) \
do { \
Tcl_ObjInternalRep ir; \
(resPtr)->refCount++; \
ir.twoPtrValue.ptr1 = (resPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
/*
* Each read op must set the blocked and eof states anew, not let
* the effect of prior reads leak through.
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
| | | | | 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 |
/*
* Each read op must set the blocked and eof states anew, not let
* the effect of prior reads leak through.
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (WillRead(chanPtr) == -1) {
return -1;
}
bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData,
dst, dstSize, &result);
/*
* Stop any flag leakage through stacked channel levels.
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (bytesRead == -1) {
if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
SetFlag(chanPtr->state, CHANNEL_BLOCKED);
result = EAGAIN;
|
| ︙ | ︙ | |||
582 583 584 585 586 587 588 |
int doflushnb;
/*
* Fetch the pre-TIP#398 compatibility flag.
*/
{
| | | | | | | | | | | | | | | | | | | | | | | | | 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 |
int doflushnb;
/*
* Fetch the pre-TIP#398 compatibility flag.
*/
{
const char *s;
Tcl_DString ds;
s = TclGetEnv("TCL_FLUSH_NONBLOCKING_ON_EXIT", &ds);
doflushnb = ((s != NULL) && strcmp(s, "0"));
if (s != NULL) {
Tcl_DStringFree(&ds);
}
}
/*
* Walk all channel state structures known to this thread and close
* corresponding channels.
*/
while (active) {
/*
* Iterate through the open channel list, and find the first channel
* that isn't dead. We start from the head of the list each time,
* because the close action on one channel can close others.
*/
active = 0;
for (statePtr = tsdPtr->firstCSPtr;
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
if (GotFlag(statePtr, CHANNEL_DEAD)) {
continue;
}
if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED )
|| GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
active = 1;
break;
}
}
/*
* We've found a live (or bg-closing) channel. Close it.
*/
if (active) {
TclChannelPreserve((Tcl_Channel)chanPtr);
/*
* TIP #398: by default, we no longer set the channel back into
* blocking mode. To restore the old blocking behavior, the
* environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set
* and not be "0".
*/
if (doflushnb) {
/*
* Set the channel back into blocking mode to ensure that we
* wait for all data to flush out.
*/
(void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
"-blocking", "on");
}
if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
(chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
(chanPtr == (Channel *) tsdPtr->stderrChannel)) {
/*
* Decrement the refcount which was earlier artificially
* bumped up to keep the channel from being closed.
|
| ︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 |
ChannelState *statePtr; /* State of the real channel. */
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 |
ChannelState *statePtr; /* State of the real channel. */
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
" of channel", -1));
}
return TCL_ERROR;
}
if (DetachChannel(interp, chan) != TCL_OK) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
1460 1461 1462 1463 1464 1465 1466 |
}
}
hTblPtr = GetChannelTable(interp);
hPtr = Tcl_FindHashEntry(hTblPtr, name);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
}
}
hTblPtr = GetChannelTable(interp);
hPtr = Tcl_FindHashEntry(hTblPtr, name);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can not find channel named \"%s\"", chanName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, (char *)NULL);
return NULL;
}
/*
* Always return bottom-most channel in the stack. This one lives the
* longest - other channels may go away unnoticed. The other APIs
* compensate where necessary to retrieve the topmost channel again.
|
| ︙ | ︙ | |||
1523 1524 1525 1526 1527 1528 1529 |
if (interp == NULL) {
return TCL_ERROR;
}
ChanGetInternalRep(objPtr, resPtr);
if (resPtr) {
/*
| | | | 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 |
if (interp == NULL) {
return TCL_ERROR;
}
ChanGetInternalRep(objPtr, resPtr);
if (resPtr) {
/*
* Confirm validity of saved lookup results.
*/
statePtr = resPtr->statePtr;
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
&& (resPtr->epoch == statePtr->epoch)) {
/*
* Have a valid saved lookup. Jump to end to return it.
|
| ︙ | ︙ | |||
1548 1549 1550 1551 1552 1553 1554 |
if (resPtr) {
Tcl_StoreInternalRep(objPtr, &chanObjType, NULL);
}
return TCL_ERROR;
}
if (resPtr && resPtr->refCount == 1) {
| < | < < > | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 |
if (resPtr) {
Tcl_StoreInternalRep(objPtr, &chanObjType, NULL);
}
return TCL_ERROR;
}
if (resPtr && resPtr->refCount == 1) {
/* Re-use the ResolvedCmdName struct */
Tcl_Release(resPtr->statePtr);
} else {
resPtr = (ResolvedChanName *) Tcl_Alloc(sizeof(ResolvedChanName));
resPtr->refCount = 0;
ChanSetInternalRep(objPtr, resPtr); /* Overwrites, if needed */
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_CreateChannel(
const Tcl_ChannelType *typePtr, /* The channel type record. */
const char *chanName, /* Name of channel to record. */
| | < < < < < < > | < < | < < | 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 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_CreateChannel(
const Tcl_ChannelType *typePtr, /* The channel type record. */
const char *chanName, /* Name of channel to record. */
void *instanceData, /* Instance specific data. */
int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if
* the channel is readable, writable. */
{
Channel *chanPtr; /* The channel structure newly created. */
ChannelState *statePtr; /* The stack-level independent state info for
* the channel. */
const char *name;
char *tmp;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (typePtr->typeName == NULL) {
Tcl_Panic("channel does not have a type name");
}
if (Tcl_ChannelVersion(typePtr) != TCL_CHANNEL_VERSION_5) {
Tcl_Panic("channel type %s must be version TCL_CHANNEL_VERSION_5", typePtr->typeName);
}
if (typePtr->close2Proc == NULL) {
Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName);
}
if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) {
|
| ︙ | ︙ | |||
1654 1655 1656 1657 1658 1659 1660 |
* information for the channel.
*/
if (chanName != NULL) {
unsigned len = strlen(chanName) + 1;
/*
| | | | < < < < < < | 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 |
* information for the channel.
*/
if (chanName != NULL) {
unsigned len = strlen(chanName) + 1;
/*
* Make sure we allocate at least 7 bytes, so it fits for "stdout"
* later.
*/
tmp = (char *)Tcl_Alloc((len < 7) ? 7 : len);
strcpy(tmp, chanName);
} else {
tmp = (char *)Tcl_Alloc(7);
tmp[0] = '\0';
}
statePtr->channelName = tmp;
statePtr->flags = mask;
statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
*/
name = Tcl_GetEncodingName(NULL);
statePtr->encoding = Tcl_GetEncoding(NULL, name);
statePtr->inputEncodingState = NULL;
statePtr->inputEncodingFlags = TCL_ENCODING_START;
statePtr->outputEncodingState = NULL;
|
| ︙ | ︙ | |||
1813 1814 1815 1816 1817 1818 1819 |
Tcl_Channel
Tcl_StackChannel(
Tcl_Interp *interp, /* The interpreter we are working in */
const Tcl_ChannelType *typePtr,
/* The channel type record for the new
* channel. */
| | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 |
Tcl_Channel
Tcl_StackChannel(
Tcl_Interp *interp, /* The interpreter we are working in */
const Tcl_ChannelType *typePtr,
/* The channel type record for the new
* channel. */
void *instanceData, /* Instance specific data for the new
* channel. */
int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if
* the channel is readable, writable. */
Tcl_Channel prevChan) /* The channel structure to replace */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Channel *chanPtr, *prevChanPtr;
|
| ︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 |
while ((statePtr != NULL) && (statePtr->topChanPtr != prevChanPtr)) {
statePtr = statePtr->nextCSPtr;
}
if (statePtr == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
while ((statePtr != NULL) && (statePtr->topChanPtr != prevChanPtr)) {
statePtr = statePtr->nextCSPtr;
}
if (statePtr == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't find state for channel \"%s\"",
Tcl_GetChannelName(prevChan)));
}
return NULL;
}
/*
* Here we check if the given "mask" matches the "flags" of the already
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 |
* the stacking state of this channel during its operations.
*/
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 |
* the stacking state of this channel during its operations.
*/
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not flush channel \"%s\"",
Tcl_GetChannelName(prevChan)));
}
return NULL;
}
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
|
| ︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 |
* bypass area into the regular interpreter result. Fall back
* to the regular message if nothing was found in the
* bypasses.
*/
if (!TclChanCaughtErrorBypass(interp, chan) && interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 |
* bypass area into the regular interpreter result. Fall back
* to the regular message if nothing was found in the
* bypasses.
*/
if (!TclChanCaughtErrorBypass(interp, chan) && interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not flush channel \"%s\"",
Tcl_GetChannelName((Tcl_Channel) chanPtr)));
}
return TCL_ERROR;
}
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
}
/*
* Anything in the input queue and the push-back buffers of the
* transformation going away is transformed data, but not yet read. As
* unstacking means that the caller does not want to see transformed
|
| ︙ | ︙ | |||
2419 2420 2421 2422 2423 2424 2425 |
{
Channel *chanPtr; /* The actual channel. */
void *handle;
int result;
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
if (!chanPtr->typePtr->getHandleProc) {
| | | | | 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 |
{
Channel *chanPtr; /* The actual channel. */
void *handle;
int result;
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
if (!chanPtr->typePtr->getHandleProc) {
Tcl_SetChannelError(chan, Tcl_ObjPrintf(
"channel \"%s\" does not support OS handles",
Tcl_GetChannelName(chan)));
return TCL_ERROR;
}
result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction,
&handle);
if (handlePtr) {
*handlePtr = handle;
}
|
| ︙ | ︙ | |||
2451 2452 2453 2454 2455 2456 2457 | * May leave an error message in the interp. * *---------------------------------------------------------------------- */ int Tcl_RemoveChannelMode( | | | | | | | 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 |
* May leave an error message in the interp.
*
*----------------------------------------------------------------------
*/
int
Tcl_RemoveChannelMode(
Tcl_Interp *interp, /* The interp for an error message. Allowed to be NULL. */
Tcl_Channel chan, /* The channel which is modified. */
int mode) /* The access mode to drop from the channel */
{
const char* emsg;
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of actual channel. */
if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
emsg = "Illegal mode value.";
goto error;
}
if (0 == (GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) {
emsg = "Bad mode, would make channel inacessible";
goto error;
}
ResetFlag(statePtr, mode);
return TCL_OK;
error:
|
| ︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 |
if (!GotFlag(statePtr, CHANNEL_DEAD)) {
return 0;
}
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 |
if (!GotFlag(statePtr, CHANNEL_DEAD)) {
return 0;
}
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to access channel: invalid channel", -1));
}
return 1;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3013 3014 3015 3016 3017 3018 3019 |
*/
if (GotFlag(statePtr, CHANNEL_CLOSEDWRITE) &&
(statePtr->outQueueHead == NULL) &&
((statePtr->curOutPtr == NULL) ||
IsBufferEmpty(statePtr->curOutPtr))) {
errorCode = CloseChannelPart(interp, chanPtr, errorCode,
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 |
*/
if (GotFlag(statePtr, CHANNEL_CLOSEDWRITE) &&
(statePtr->outQueueHead == NULL) &&
((statePtr->curOutPtr == NULL) ||
IsBufferEmpty(statePtr->curOutPtr))) {
errorCode = CloseChannelPart(interp, chanPtr, errorCode,
TCL_CLOSE_WRITE);
goto done;
}
done:
TclChannelRelease((Tcl_Channel)chanPtr);
return errorCode;
}
static void
FreeChannelState(
void *blockPtr) /* Channel state to free. */
{
ChannelState *statePtr = (ChannelState *)blockPtr;
/*
* Even after close some members can be filled again (in events etc).
* Test in bug [79474c588] illustrates one leak (on remaining chanMsg).
* Possible other fields need freeing on some constellations.
*/
DiscardInputQueued(statePtr, 1);
if (statePtr->curOutPtr != NULL) {
ReleaseChannelBuffer(statePtr->curOutPtr);
}
DiscardOutputQueued(statePtr);
DeleteTimerHandler(statePtr);
if (statePtr->chanMsg) {
Tcl_DecrRefCount(statePtr->chanMsg);
}
if (statePtr->unreportedMsg) {
Tcl_DecrRefCount(statePtr->unreportedMsg);
}
Tcl_Free(statePtr);
}
/*
*----------------------------------------------------------------------
*
* CloseChannel --
*
* Utility procedure to close a channel and free associated resources.
|
| ︙ | ︙ | |||
3157 3158 3159 3160 3161 3162 3163 |
Tcl_SetErrno(errorCode);
}
}
/*
* Cancel any outstanding timer.
*/
| < > | 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 |
Tcl_SetErrno(errorCode);
}
}
/*
* Cancel any outstanding timer.
*/
DeleteTimerHandler(statePtr);
/*
* Mark the channel as deleted by clearing the type structure.
*/
if (chanPtr->downChanPtr != NULL) {
Channel *downChanPtr = chanPtr->downChanPtr;
|
| ︙ | ︙ | |||
3186 3187 3188 3189 3190 3191 3192 |
* There is only the TOP Channel, so we free the remaining pointers we
* have and then ourselves. Since this is the last of the channels in the
* stack, make sure to free the ChannelState structure associated with it.
*/
ChannelFree(chanPtr);
| | | 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 |
* There is only the TOP Channel, so we free the remaining pointers we
* have and then ourselves. Since this is the last of the channels in the
* stack, make sure to free the ChannelState structure associated with it.
*/
ChannelFree(chanPtr);
Tcl_EventuallyFree(statePtr, FreeChannelState);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3462 3463 3464 3465 3466 3467 3468 |
if (statePtr->refCount > 0) {
Tcl_Panic("called Tcl_Close on channel with refCount > 0");
}
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 |
if (statePtr->refCount > 0) {
Tcl_Panic("called Tcl_Close on channel with refCount > 0");
}
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
" of channel", -1));
}
return TCL_ERROR;
}
SetFlag(statePtr, CHANNEL_INCLOSE);
/*
* When the channel has an escape sequence driven encoding such as
|
| ︙ | ︙ | |||
3508 3509 3510 3511 3512 3513 3514 |
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
}
}
Tcl_ClearChannelHandlers(chan);
| < < < < < | 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 |
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
}
}
Tcl_ClearChannelHandlers(chan);
/*
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
|
| ︙ | ︙ | |||
3567 3568 3569 3570 3571 3572 3573 |
result = EINVAL;
}
if (stickyError != 0) {
Tcl_SetErrno(stickyError);
if (interp != NULL) {
Tcl_SetObjResult(interp,
| | | 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 |
result = EINVAL;
}
if (stickyError != 0) {
Tcl_SetErrno(stickyError);
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_PosixError(interp), -1));
}
return TCL_ERROR;
}
/*
* Bug 97069ea11a: set error message if a flush code is set and no error
* message set up to now.
|
| ︙ | ︙ | |||
3676 3677 3678 3679 3680 3681 3682 |
if (flags & TCL_CLOSE_READ) {
msg = "read";
} else {
msg = "write";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | | 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 |
if (flags & TCL_CLOSE_READ) {
msg = "read";
} else {
msg = "write";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Half-close of %s-side not possible, side not opened or"
" already closed", msg));
return TCL_ERROR;
}
/*
* A user may try to call half-close from within a channel close handler.
* That won't do.
*/
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
" of channel", -1));
}
return TCL_ERROR;
}
if (flags & TCL_CLOSE_READ) {
/*
* Call the finalization code directly. There are no events to handle,
|
| ︙ | ︙ | |||
3751 3752 3753 3754 3755 3756 3757 |
*----------------------------------------------------------------------
*/
static int
CloseWrite(
Tcl_Interp *interp, /* Interpreter for errors. */
Channel *chanPtr) /* The channel whose write side is being
| | | | | 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 |
*----------------------------------------------------------------------
*/
static int
CloseWrite(
Tcl_Interp *interp, /* Interpreter for errors. */
Channel *chanPtr) /* The channel whose write side is being
* closed. May still be used by some
* interpreter */
{
/*
* Notes: clear-channel-handlers - write side only ? or keep around, just
* not called.
*
* No close callbacks are run - channel is still open (read side)
*/
ChannelState *statePtr = chanPtr->state;
/* State of real IO channel. */
int flushcode;
int result = 0;
/*
* The call to FlushChannel will flush any queued output and invoke the
* close function of the channel driver, or it will set up the channel to
* be flushed and closed asynchronously.
|
| ︙ | ︙ | |||
3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 |
chanPtr = (Channel *) channel;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
/*
* Cancel any outstanding timer.
*/
DeleteTimerHandler(statePtr);
/*
* Remove any references to channel handlers for this channel that may be
* about to be invoked.
*/
| > | 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 |
chanPtr = (Channel *) channel;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
/*
* Cancel any outstanding timer.
*/
DeleteTimerHandler(statePtr);
/*
* Remove any references to channel handlers for this channel that may be
* about to be invoked.
*/
|
| ︙ | ︙ | |||
3993 3994 3995 3996 3997 3998 3999 |
}
statePtr->chPtr = NULL;
/*
* Cancel any pending copy operation.
*/
| > | > > > | > > | 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 |
}
statePtr->chPtr = NULL;
/*
* Cancel any pending copy operation.
*/
if (statePtr->csPtrR) {
StopCopy(statePtr->csPtrR);
statePtr->csPtrR = NULL;
}
if (statePtr->csPtrW) {
StopCopy(statePtr->csPtrW);
statePtr->csPtrW = NULL;
}
/*
* Must set the interest mask now to 0, otherwise infinite loops will
* occur if Tcl_DoOneEvent is called before the channel is finally deleted
* in FlushChannel. This can happen if the channel has a background flush
* active.
*/
|
| ︙ | ︙ | |||
4258 4259 4260 4261 4262 4263 4264 |
Tcl_SetErrno(EILSEQ);
result = TCL_INDEX_NONE;
} else {
result = WriteBytes(chanPtr, src, srcLen);
}
return result;
} else {
| | | | | | | | 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 |
Tcl_SetErrno(EILSEQ);
result = TCL_INDEX_NONE;
} else {
result = WriteBytes(chanPtr, src, srcLen);
}
return result;
} else {
src = TclGetStringFromObj(objPtr, &srcLen);
return WriteChars(chanPtr, src, srcLen);
}
}
static void
WillWrite(
Channel *chanPtr)
{
int inputBuffered;
if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
&& ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
int ignore;
DiscardInputQueued(chanPtr->state, 0);
ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore);
}
}
static int
WillRead(
Channel *chanPtr)
{
if (chanPtr->typePtr == NULL) {
/*
* Prevent read attempts on a closed channel.
*/
DiscardInputQueued(chanPtr->state, 0);
Tcl_SetErrno(EINVAL);
return -1;
}
if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
&& (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
/*
* CAVEAT - The assumption here is that FlushChannel() will push out
* the bytes of any writes that are in progress. Since this is a
* seekable channel, we assume it is not one that can block and force
* bg flushing. Channels we know that can do that - sockets, pipes -
* are not seekable. If the assumption is wrong, more drastic measures
* may be required here like temporarily setting the channel into
* blocking mode.
*/
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4335 4336 4337 4338 4339 4340 4341 |
*----------------------------------------------------------------------
*/
static Tcl_Size
Write(
Channel *chanPtr, /* The channel to buffer output for. */
const char *src, /* UTF-8 string to write. */
| | | | 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 |
*----------------------------------------------------------------------
*/
static Tcl_Size
Write(
Channel *chanPtr, /* The channel to buffer output for. */
const char *src, /* UTF-8 string to write. */
Tcl_Size srcLen, /* Length of UTF-8 string in bytes. */
Tcl_Encoding encoding)
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
char *nextNewLine = NULL;
int endEncoding, needNlFlush = 0;
Tcl_Size saved = 0, total = 0, flushed = 0;
char safe[BUFFER_PADDING];
int encodingError = 0;
if (srcLen) {
WillWrite(chanPtr);
}
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
|
| ︙ | ︙ | |||
4408 4409 4410 4411 4412 4413 4414 | * See io-75.2, TCL bug 6978c01b65. * Check, if an encoding error occured and should be reported to the * script level. * This happens, if a written character may not be represented by the * current output encoding and strict encoding is active. */ | < | < | | | | < | 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 |
* See io-75.2, TCL bug 6978c01b65.
* Check, if an encoding error occured and should be reported to the
* script level.
* This happens, if a written character may not be represented by the
* current output encoding and strict encoding is active.
*/
if ((result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) ||
/*
* We're reading from invalid/incomplete UTF-8.
*/
((result != TCL_OK) && (srcRead + dstWrote == 0))) {
encodingError = 1;
result = TCL_OK;
}
bufPtr->nextAdded += dstWrote;
src += srcRead;
srcLen -= srcRead;
|
| ︙ | ︙ | |||
4491 4492 4493 4494 4495 4496 4497 |
if (IsBufferFull(bufPtr)) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
flushed += statePtr->bufSize;
/*
| | | | | | | | | | | 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 |
if (IsBufferFull(bufPtr)) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
flushed += statePtr->bufSize;
/*
* We just flushed. So if we have needNlFlush set to record that
* we need to flush because there is a (translated) newline in the
* buffer, that's likely not true any more. But there is a tricky
* exception. If we have saved bytes that did not really get
* flushed and those bytes came from a translation of a newline as
* the last thing taken from the src array, then needNlFlush needs
* to remain set to flag that the next buffer still needs a
* newline flush.
*/
if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
needNlFlush = 0;
}
}
}
if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
|
| ︙ | ︙ | |||
4655 4656 4657 4658 4659 4660 4661 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
| | | 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
(void)TclGetStringFromObj(objPtr, &oldLength);
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
|
| ︙ | ︙ | |||
4982 4983 4984 4985 4986 4987 4988 |
/*
* Update the notifier state so we don't block while there is still data
* in the buffers.
*/
done:
assert(!GotFlag(statePtr, CHANNEL_EOF)
| | < | 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 |
/*
* Update the notifier state so we don't block while there is still data
* in the buffers.
*/
done:
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF|CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
/*
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
|
| ︙ | ︙ | |||
5123 5124 5125 5126 5127 5128 5129 |
} else {
/*
* Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new
* CHANNEL_STICKY_EOF set in this routine leads to return before
* coming back here. When we are not dealing with
* CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an empty buffer.
* Here the buffer is non-empty so we know we're a non-EOF.
| | | 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 |
} else {
/*
* Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new
* CHANNEL_STICKY_EOF set in this routine leads to return before
* coming back here. When we are not dealing with
* CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an empty buffer.
* Here the buffer is non-empty so we know we're a non-EOF.
*/
assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF));
assert(!GotFlag(statePtr, CHANNEL_EOF));
}
dst = (unsigned char *) RemovePoint(bufPtr);
dstEnd = dst + BytesLeft(bufPtr);
|
| ︙ | ︙ | |||
5418 5419 5420 5421 5422 5423 5424 |
} else {
/*
* Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new
* CHANNEL_STICKY_EOF set in this routine leads to return before
* coming back here. When we are not dealing with CHANNEL_STICKY_EOF,
* a CHANNEL_EOF implies an empty buffer. Here the buffer is
* non-empty so we know we're a non-EOF.
| | | 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 |
} else {
/*
* Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new
* CHANNEL_STICKY_EOF set in this routine leads to return before
* coming back here. When we are not dealing with CHANNEL_STICKY_EOF,
* a CHANNEL_EOF implies an empty buffer. Here the buffer is
* non-empty so we know we're a non-EOF.
*/
assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF));
assert(!GotFlag(statePtr, CHANNEL_EOF));
}
/*
* Convert some of the bytes from the channel buffer to UTF-8. Space in
|
| ︙ | ︙ | |||
5661 5662 5663 5664 5665 5666 5667 |
* buffer because the caller could change the channel's encoding which
* could change the interpretation of whether those bytes really made
* up multi-byte characters after all.
*/
nextPtr = bufPtr->nextPtr;
for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) {
| | | | 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 |
* buffer because the caller could change the channel's encoding which
* could change the interpretation of whether those bytes really made
* up multi-byte characters after all.
*/
nextPtr = bufPtr->nextPtr;
for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) {
Tcl_Size extra;
extra = SpaceLeft(bufPtr);
if (extra > 0) {
memcpy(InsertPoint(bufPtr),
nextPtr->buf + (BUFFER_PADDING - extra),
extra);
bufPtr->nextAdded += extra;
nextPtr->nextRemoved = BUFFER_PADDING;
}
bufPtr = nextPtr;
}
}
}
|
| ︙ | ︙ | |||
5780 5781 5782 5783 5784 5785 5786 | memcpy(readBuf, RemovePoint(bufPtr), toCopy); bufPtr->nextRemoved += toCopy; copied += toCopy; readBuf += toCopy; bytesToRead -= toCopy; /* | | | | 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 |
memcpy(readBuf, RemovePoint(bufPtr), toCopy);
bufPtr->nextRemoved += toCopy;
copied += toCopy;
readBuf += toCopy;
bytesToRead -= toCopy;
/*
* If the current buffer is empty recycle it.
*/
if (IsBufferEmpty(bufPtr)) {
chanPtr->inQueueHead = bufPtr->nextPtr;
if (chanPtr->inQueueHead == NULL) {
chanPtr->inQueueTail = NULL;
}
RecycleBuffer(chanPtr->state, bufPtr, 0);
|
| ︙ | ︙ | |||
5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 |
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
/* TODO: UpdateInterest not needed here? */
UpdateInterest(chanPtr);
Tcl_SetErrno(EILSEQ);
return -1;
}
/*
* Early out when next read will see eofchar.
*
* NOTE: See DoRead for argument that it's a bug (one we're keeping) to
* have this escape before the one for zero-char read request.
*/
| > | 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 |
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
/* TODO: UpdateInterest not needed here? */
UpdateInterest(chanPtr);
Tcl_SetErrno(EILSEQ);
return -1;
}
/*
* Early out when next read will see eofchar.
*
* NOTE: See DoRead for argument that it's a bug (one we're keeping) to
* have this escape before the one for zero-char read request.
*/
|
| ︙ | ︙ | |||
6104 6105 6106 6107 6108 6109 6110 |
/*
* Update the notifier state so we don't block while there is still data
* in the buffers.
*/
assert(!GotFlag(statePtr, CHANNEL_EOF)
| | < | | 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 |
/*
* Update the notifier state so we don't block while there is still data
* in the buffers.
*/
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF|CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
/* This must comes after UpdateInterest(), which may set errno */
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& (!copied || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
/* Channel either is blocking or is nonblocking with no data
* succesfully red before the error. Return an error so that callers
|
| ︙ | ︙ | |||
6254 6255 6256 6257 6258 6259 6260 |
* expand when converted to UTF-8 chars. This guess comes from analyzing
* how many characters were produced by the previous pass.
*/
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
| > | > | | 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 |
* expand when converted to UTF-8 chars. This guess comes from analyzing
* how many characters were produced by the previous pass.
*/
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
if (dstLimit <= 0) {
dstLimit = INT_MAX; /* avoid overflow */
}
(void)TclGetStringFromObj(objPtr, &numBytes);
TclAppendUtfToUtf(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
Tcl_Size size;
dst = TclGetStringStorage(objPtr, &size) + numBytes;
dstLimit = (size - numBytes) > INT_MAX ? INT_MAX : (size - numBytes);
} else {
|
| ︙ | ︙ | |||
6312 6313 6314 6315 6316 6317 6318 | || (statePtr->inputEncodingFlags & TCL_ENCODING_END) == 0); code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, flags, &statePtr->inputEncodingState, dst, dstLimit, &srcRead, &dstDecoded, &numChars); if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX | < < | < < | 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 |
|| (statePtr->inputEncodingFlags & TCL_ENCODING_END) == 0);
code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen,
flags, &statePtr->inputEncodingState,
dst, dstLimit, &srcRead, &dstDecoded, &numChars);
if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX
|| (code == TCL_CONVERT_MULTIBYTE && GotFlag(statePtr, CHANNEL_EOF))) {
SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
code = TCL_OK;
}
/*
* Perform the translation transformation in place. Read no more than
* the dstDecoded bytes the encoding transformation actually produced.
|
| ︙ | ︙ | |||
6691 6692 6693 6694 6695 6696 6697 |
char *dst = dstStart;
int lesser = (dstLen < srcLen) ? dstLen : srcLen;
while ((crFound = (const char *)memchr(src, '\r', lesser))) {
int numBytes = crFound - src;
memmove(dst, src, numBytes);
| | > | > | > | > | > | > > > | | > | > | > | 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 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 |
char *dst = dstStart;
int lesser = (dstLen < srcLen) ? dstLen : srcLen;
while ((crFound = (const char *)memchr(src, '\r', lesser))) {
int numBytes = crFound - src;
memmove(dst, src, numBytes);
dst += numBytes;
dstLen -= numBytes;
src += numBytes;
srcLen -= numBytes;
if (srcLen == 1) {
/* valid src bytes end in \r */
if (eof) {
*dst++ = '\r';
src++;
srcLen--;
} else {
lesser = 0;
break;
}
} else if (src[1] == '\n') {
*dst++ = '\n';
src += 2;
srcLen -= 2;
} else {
*dst++ = '\r';
src++;
srcLen--;
}
dstLen--;
lesser = (dstLen < srcLen) ? dstLen : srcLen;
}
memmove(dst, src, lesser);
srcLen = src + lesser - srcStart;
dstLen = dst + lesser - dstStart;
break;
}
case TCL_TRANSLATE_AUTO: {
const char *crFound, *src = srcStart;
char *dst = dstStart;
int lesser;
if (GotFlag(statePtr, INPUT_SAW_CR) && srcLen) {
if (*src == '\n') {
src++;
srcLen--;
}
ResetFlag(statePtr, INPUT_SAW_CR);
}
lesser = (dstLen < srcLen) ? dstLen : srcLen;
while ((crFound = (const char *) memchr(src, '\r', lesser))) {
int numBytes = crFound - src;
memmove(dst, src, numBytes);
dst[numBytes] = '\n';
dst += numBytes + 1;
dstLen -= numBytes + 1;
src += numBytes + 1;
srcLen -= numBytes + 1;
if (srcLen == 0) {
SetFlag(statePtr, INPUT_SAW_CR);
} else if (*src == '\n') {
src++;
srcLen--;
}
lesser = (dstLen < srcLen) ? dstLen : srcLen;
}
memmove(dst, src, lesser);
srcLen = src + lesser - srcStart;
dstLen = dst + lesser - dstStart;
break;
|
| ︙ | ︙ | |||
7051 7052 7053 7054 7055 7056 7057 | bufPtr = statePtr->saveInBufPtr; statePtr->saveInBufPtr = NULL; /* * Check the actual buffersize against the requested buffersize. * Saved buffers of the wrong size are squashed. This is done to honor * dynamic changes of the buffersize made by the user. | | | 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 |
bufPtr = statePtr->saveInBufPtr;
statePtr->saveInBufPtr = NULL;
/*
* Check the actual buffersize against the requested buffersize.
* Saved buffers of the wrong size are squashed. This is done to honor
* dynamic changes of the buffersize made by the user.
*
* TODO: Tests to cover this.
*/
if ((bufPtr != NULL)
&& (bufPtr->bufLength != statePtr->bufSize + BUFFER_PADDING)) {
ReleaseChannelBuffer(bufPtr);
bufPtr = NULL;
|
| ︙ | ︙ | |||
7157 7158 7159 7160 7161 7162 7163 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
| | < | 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Compute how much input and output is buffered. If both input and output
* is buffered, cannot compute the current position.
|
| ︙ | ︙ | |||
7322 7323 7324 7325 7326 7327 7328 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow tell on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
| | < | 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow tell on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Compute how much input and output is buffered. If both input and output
* is buffered, cannot compute the current position.
|
| ︙ | ︙ | |||
7410 7411 7412 7413 7414 7415 7416 |
* Seek first to force a total flush of all pending buffers and ditch any
* preread input data.
*/
WillWrite(chanPtr);
if (WillRead(chanPtr) == -1) {
| | | 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 |
* Seek first to force a total flush of all pending buffers and ditch any
* preread input data.
*/
WillWrite(chanPtr);
if (WillRead(chanPtr) == -1) {
return TCL_ERROR;
}
/*
* We're all flushed to disk now and we also don't have any unfortunate
* input baggage around either; can truncate with impunity.
*/
|
| ︙ | ︙ | |||
7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 |
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Eof --
*
* Returns 1 if the channel is at EOF, 0 otherwise.
*
* Results:
* 1 or 0, always.
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7533 7534 7535 7536 7537 7538 7539 7540 7541 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 |
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclChanIsBinary --
*
* Returns 1 if the channel is a binary channel, 0 otherwise.
*
* Results:
* 1 or 0, always.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclChanIsBinary(
Tcl_Channel chan) /* Does this channel have EOF? */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return ((statePtr->encoding == GetBinaryEncoding()) && !statePtr->inEofChar
&& (!GotFlag(statePtr, TCL_READABLE) || (statePtr->inputTranslation == TCL_TRANSLATE_LF))
&& (!GotFlag(statePtr, TCL_WRITABLE) || (statePtr->outputTranslation == TCL_TRANSLATE_LF)));
}
/*
*----------------------------------------------------------------------
*
* Tcl_Eof --
*
* Returns 1 if the channel is at EOF, 0 otherwise.
*
* Results:
* 1 or 0, always.
*
|
| ︙ | ︙ | |||
7543 7544 7545 7546 7547 7548 7549 |
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
return 0;
}
return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0;
}
| < | 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 |
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.
*
|
| ︙ | ︙ | |||
7569 7570 7571 7572 7573 7574 7575 |
Tcl_Channel chan)
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return GotFlag(statePtr, CHANNEL_NONBLOCKING) ? 0 : 1;
}
| | | 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 |
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.
*
|
| ︙ | ︙ | |||
7845 7846 7847 7848 7849 7850 7851 |
{
if (interp != NULL) {
const char *genericopt =
"blocking buffering buffersize encoding eofchar profile translation";
const char **argv;
Tcl_Size argc, i;
Tcl_DString ds;
| | | | | 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 |
{
if (interp != NULL) {
const char *genericopt =
"blocking buffering buffersize encoding eofchar profile translation";
const char **argv;
Tcl_Size argc, i;
Tcl_DString ds;
Tcl_Obj *errObj;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, genericopt, -1);
if (optionList && (*optionList)) {
TclDStringAppendLiteral(&ds, " ");
Tcl_DStringAppend(&ds, optionList, -1);
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
&argc, &argv) != TCL_OK) {
Tcl_Panic("malformed option list in channel driver");
}
Tcl_ResetResult(interp);
errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
optionName ? optionName : "");
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
Tcl_Free((void *)argv);
}
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
8128 8129 8130 8131 8132 8133 8134 |
/*
* If the channel is in the middle of a background copy, fail.
*/
if (statePtr->csPtrR || statePtr->csPtrW) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 |
/*
* If the channel is in the middle of a background copy, fail.
*/
if (statePtr->csPtrR || statePtr->csPtrW) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to set channel options: background copy in"
" progress", -1));
}
return TCL_ERROR;
}
/*
* Disallow options on dead channels -- channels that have been closed but
* not yet been deallocated. Such channels can be found if the exit
|
| ︙ | ︙ | |||
8178 8179 8180 8181 8182 8183 8184 |
ResetFlag(statePtr, CHANNEL_UNBUFFERED);
SetFlag(statePtr, CHANNEL_LINEBUFFERED);
} else if ((newValue[0] == 'n') &&
(strncmp(newValue, "none", len) == 0)) {
ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
SetFlag(statePtr, CHANNEL_UNBUFFERED);
} else if (interp) {
| | | | | | 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 |
ResetFlag(statePtr, CHANNEL_UNBUFFERED);
SetFlag(statePtr, CHANNEL_LINEBUFFERED);
} else if ((newValue[0] == 'n') &&
(strncmp(newValue, "none", len) == 0)) {
ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
SetFlag(statePtr, CHANNEL_UNBUFFERED);
} else if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -buffering: must be one of"
" full, line, or none", -1));
return TCL_ERROR;
}
return TCL_OK;
} else if (HaveOpt(7, "-buffersize")) {
Tcl_WideInt newBufferSize;
Tcl_Obj obj;
int code;
|
| ︙ | ︙ | |||
8206 8207 8208 8209 8210 8211 8212 |
}
Tcl_SetChannelBufferSize(chan, newBufferSize);
return TCL_OK;
} else if (HaveOpt(2, "-encoding")) {
Tcl_Encoding encoding;
int profile;
| | > > > > | > > | 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 |
}
Tcl_SetChannelBufferSize(chan, newBufferSize);
return TCL_OK;
} else if (HaveOpt(2, "-encoding")) {
Tcl_Encoding encoding;
int profile;
if ((newValue[0] == '\0') || !strcmp(newValue, "binary")) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown encoding \"%s\": No longer supported.\n"
"\tplease use either \"-translation binary\" "
"or \"-encoding iso8859-1\"", newValue));
}
return TCL_ERROR;
} else {
encoding = Tcl_GetEncoding(interp, newValue);
if (encoding == NULL) {
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
8328 8329 8330 8331 8332 8333 8334 |
translation = TCL_TRANSLATE_CRLF;
} else if (strcmp(readMode, "platform") == 0) {
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
| | | 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 |
translation = TCL_TRANSLATE_CRLF;
} else if (strcmp(readMode, "platform") == 0) {
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
/*
* Reset the EOL flags since we need to look at any buffered data
|
| ︙ | ︙ | |||
8377 8378 8379 8380 8381 8382 8383 |
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else if (strcmp(writeMode, "platform") == 0) {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
| | | 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 |
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else if (strcmp(writeMode, "platform") == 0) {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
}
Tcl_Free((void *)argv);
return TCL_OK;
|
| ︙ | ︙ | |||
8703 8704 8705 8706 8707 8708 8709 |
mask &= ~TCL_EXCEPTION;
if (!statePtr->timer) {
TclChannelPreserve((Tcl_Channel)chanPtr);
statePtr->timerChanPtr = chanPtr;
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
| | < < < < < < < < < < < < | 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 |
mask &= ~TCL_EXCEPTION;
if (!statePtr->timer) {
TclChannelPreserve((Tcl_Channel)chanPtr);
statePtr->timerChanPtr = chanPtr;
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
}
}
}
ChanWatch(chanPtr, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
|
| ︙ | ︙ | |||
8747 8748 8749 8750 8751 8752 8753 |
ChannelTimerProc(
void *clientData)
{
Channel *chanPtr = (Channel *)clientData;
/* State info for channel */
ChannelState *statePtr = chanPtr->state;
| < < < < < < | > > | < | | | < < < < < < < < < < < < < | < < | > | | | < < > | | < < | < < < < < < | < | < | > | 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 |
ChannelTimerProc(
void *clientData)
{
Channel *chanPtr = (Channel *)clientData;
/* State info for channel */
ChannelState *statePtr = chanPtr->state;
if (chanPtr->typePtr == NULL) {
statePtr->timer = NULL;
TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
statePtr->timerChanPtr = NULL;
} else {
if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
&& IsBufferReady(statePtr->inQueueHead)) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
Tcl_Preserve(statePtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
Tcl_Release(statePtr);
} else {
statePtr->timer = NULL;
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
statePtr->timerChanPtr = NULL;
}
}
}
static void
DeleteTimerHandler(
ChannelState *statePtr)
{
if (statePtr->timer != NULL) {
Tcl_DeleteTimerHandler(statePtr->timer);
statePtr->timer = NULL;
TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
statePtr->timerChanPtr = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChannelHandler --
*
|
| ︙ | ︙ | |||
9208 9209 9210 9211 9212 9213 9214 |
const char *chanName;
int modeIndex; /* Index of mode argument. */
int mask;
static const char *const modeOptions[] = {"readable", "writable", NULL};
static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
if ((objc != 3) && (objc != 4)) {
| | | 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 |
const char *chanName;
int modeIndex; /* Index of mode argument. */
int mask;
static const char *const modeOptions[] = {"readable", "writable", NULL};
static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channel event ?script?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0,
&modeIndex) != TCL_OK) {
return TCL_ERROR;
}
mask = maskArray[modeIndex];
|
| ︙ | ︙ | |||
9337 9338 9339 9340 9341 9342 9343 |
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
if (BUSY_STATE(inStatePtr, TCL_READABLE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 |
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
if (BUSY_STATE(inStatePtr, TCL_READABLE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" is busy", Tcl_GetChannelName(inChan)));
}
return TCL_ERROR;
}
if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" is busy", Tcl_GetChannelName(outChan)));
}
return TCL_ERROR;
}
readFlags = inStatePtr->flags;
writeFlags = outStatePtr->flags;
|
| ︙ | ︙ | |||
9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 |
* completed.
*/
csPtr = (CopyState *)Tcl_Alloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize);
csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
csPtr->readFlags = readFlags;
csPtr->writeFlags = writeFlags;
csPtr->toRead = toRead;
| > | > > > | | | | 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 |
* completed.
*/
csPtr = (CopyState *)Tcl_Alloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize);
csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
csPtr->refCount = 2; /* two references below (inStatePtr, outStatePtr) */
csPtr->readFlags = readFlags;
csPtr->writeFlags = writeFlags;
csPtr->toRead = toRead;
csPtr->total = 0;
csPtr->interp = interp;
if (cmdPtr) {
Tcl_IncrRefCount(cmdPtr);
}
csPtr->cmdPtr = cmdPtr;
TclChannelPreserve(inChan);
TclChannelPreserve(outChan);
inStatePtr->csPtrR = csPtr;
outStatePtr->csPtrW = csPtr;
if (moveBytes) {
return MoveBytes(csPtr);
}
/*
* Special handling of -size 0 async transfers, so that the -command is
* still called asynchronously.
*/
if ((nonBlocking == CHANNEL_NONBLOCKING) && (toRead == 0)) {
Tcl_CreateTimerHandler(0, ZeroTransferTimerProc, csPtr);
return TCL_OK;
}
/*
* Start copying data between the channels.
*/
return CopyData(csPtr, 0);
|
| ︙ | ︙ | |||
9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 |
Tcl_Size sizePart;
Tcl_WideInt total;
Tcl_WideInt size;
const char *buffer;
int moveBytes;
int underflow; /* Input underflow */
inChan = (Tcl_Channel) csPtr->readPtr;
outChan = (Tcl_Channel) csPtr->writePtr;
inStatePtr = csPtr->readPtr->state;
outStatePtr = csPtr->writePtr->state;
interp = csPtr->interp;
cmdPtr = csPtr->cmdPtr;
| > > | 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 |
Tcl_Size sizePart;
Tcl_WideInt total;
Tcl_WideInt size;
const char *buffer;
int moveBytes;
int underflow; /* Input underflow */
csPtr->refCount++; /* avoid freeing during handling */
inChan = (Tcl_Channel) csPtr->readPtr;
outChan = (Tcl_Channel) csPtr->writePtr;
inStatePtr = csPtr->readPtr->state;
outStatePtr = csPtr->writePtr->state;
interp = csPtr->interp;
cmdPtr = csPtr->cmdPtr;
|
| ︙ | ︙ | |||
9713 9714 9715 9716 9717 9718 9719 |
moveBytes = Lossless(inStatePtr, outStatePtr, csPtr->toRead);
if (!moveBytes) {
TclNewObj(bufObj);
Tcl_IncrRefCount(bufObj);
}
| | | 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 |
moveBytes = Lossless(inStatePtr, outStatePtr, csPtr->toRead);
if (!moveBytes) {
TclNewObj(bufObj);
Tcl_IncrRefCount(bufObj);
}
while (csPtr->toRead != 0) {
/*
* Check for unreported background errors.
*/
Tcl_GetChannelError(inChan, &msg);
if ((inStatePtr->unreportedError != 0) || (msg != NULL)) {
Tcl_SetErrno(inStatePtr->unreportedError);
|
| ︙ | ︙ | |||
9752 9753 9754 9755 9756 9757 9758 |
size = 0;
underflow = 1;
} else {
/*
* Read up to bufSize characters.
*/
| | | | | | | | | | | | | | 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 9796 9797 9798 9799 9800 9801 9802 9803 9804 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 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 9869 9870 9871 9872 9873 9874 9875 9876 9877 9878 9879 9880 9881 9882 9883 9884 9885 9886 9887 9888 9889 9890 9891 9892 9893 9894 9895 9896 9897 9898 9899 9900 9901 |
size = 0;
underflow = 1;
} else {
/*
* Read up to bufSize characters.
*/
if ((csPtr->toRead == -1)
|| (csPtr->toRead > (Tcl_WideInt)csPtr->bufSize)) {
sizeb = csPtr->bufSize;
} else {
sizeb = csPtr->toRead;
}
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) {
TclGetStringFromObj(bufObj, &sizePart);
if (sizePart > 0) {
size = sizePart;
}
}
}
underflow = (size >= 0) && (size < sizeb); /* Input underflow */
}
if (size < 0) {
readError:
if (interp) {
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error reading \"",
Tcl_GetChannelName(inChan), "\": ", (char *)NULL);
if (msg != NULL) {
Tcl_AppendObjToObj(errObj, msg);
} else {
Tcl_AppendStringsToObj(errObj, Tcl_PosixError(interp),
(char *)NULL);
}
}
if (msg != NULL) {
Tcl_DecrRefCount(msg);
}
break;
} else if (underflow) {
/*
* We had an underflow on the read side. If we are at EOF, and not
* in the synchronous part of an asynchronous fcopy, then the
* copying is done, otherwise set up a channel handler to detect
* when the channel becomes readable again.
*/
if ((size == 0) && Tcl_Eof(inChan) && !(cmdPtr && (mask == 0))) {
break;
}
if (cmdPtr && (!Tcl_Eof(inChan) || (mask == 0))
&& !(mask & TCL_READABLE)) {
if (mask & TCL_WRITABLE) {
Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr);
}
Tcl_CreateChannelHandler(inChan, TCL_READABLE, CopyEventProc,
csPtr);
}
if (size == 0) {
if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
/*
* We allowed a short read. Keep trying.
*/
continue;
}
if (bufObj != NULL) {
TclDecrRefCount(bufObj);
bufObj = NULL;
}
goto done;
}
}
/*
* Now write the buffer out.
*/
if (moveBytes) {
buffer = csPtr->buffer;
sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, size);
} else {
buffer = TclGetStringFromObj(bufObj, &sizeb);
sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb);
}
/*
* [Bug 2895565]. At this point 'size' still contains the number of
* characters which have been read. We keep this to later to
* update the totals and toRead information, see marker (UP) below. We
* must not overwrite it with 'sizeb', which is the number of written
* characters, and both EOL translation and encoding
* conversion may have changed this number unpredictably in relation
* to 'size' (It can be smaller or larger, in the latter case able to
* drive toRead below -1, causing infinite looping). Completely
* unsuitable for updating totals and toRead.
*/
if (sizeb < 0) {
writeError:
if (interp) {
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error writing \"",
Tcl_GetChannelName(outChan), "\": ", (char *)NULL);
if (msg != NULL) {
Tcl_AppendObjToObj(errObj, msg);
} else {
Tcl_AppendStringsToObj(errObj, Tcl_PosixError(interp),
(char *)NULL);
}
}
if (msg != NULL) {
Tcl_DecrRefCount(msg);
}
break;
}
|
| ︙ | ︙ | |||
9921 9922 9923 9924 9925 9926 9927 |
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
CopyEventProc, csPtr);
}
if (bufObj != NULL) {
TclDecrRefCount(bufObj);
bufObj = NULL;
}
| | | 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 |
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
CopyEventProc, csPtr);
}
if (bufObj != NULL) {
TclDecrRefCount(bufObj);
bufObj = NULL;
}
goto done;
}
/*
* For background copies, we only do one buffer per invocation so we
* don't starve the rest of the system.
*/
|
| ︙ | ︙ | |||
9943 9944 9945 9946 9947 9948 9949 |
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, CopyEventProc,
csPtr);
}
if (bufObj != NULL) {
TclDecrRefCount(bufObj);
bufObj = NULL;
}
| | | 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 |
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, CopyEventProc,
csPtr);
}
if (bufObj != NULL) {
TclDecrRefCount(bufObj);
bufObj = NULL;
}
goto done;
}
} /* while */
if (bufObj != NULL) {
TclDecrRefCount(bufObj);
bufObj = NULL;
}
|
| ︙ | ︙ | |||
9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 |
result = TCL_ERROR;
} else {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(total));
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* DoRead --
*
* Stores up to "bytesToRead" bytes in memory pointed to by "dst".
* These bytes come from reading the channel "chanPtr" and
* performing the configured translations. No encoding conversions
* are applied to the bytes being read.
*
* Results:
* The number of bytes actually stored (<= bytesToRead),
| > > > | | | | 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 10041 10042 10043 10044 10045 10046 |
result = TCL_ERROR;
} else {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(total));
}
}
}
done:
CopyDecrRefCount(csPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* DoRead --
*
* Stores up to "bytesToRead" bytes in memory pointed to by "dst".
* These bytes come from reading the channel "chanPtr" and
* performing the configured translations. No encoding conversions
* are applied to the bytes being read.
*
* Results:
* The number of bytes actually stored (<= bytesToRead),
* or TCL_INDEX_NONE if there is an error in reading the channel. Use
* Tcl_GetErrno() to retrieve the error code for the error
* that occurred.
*
* The number of bytes stored can be less than the number
* requested when
* - EOF is reached on the channel; or
* - the channel is non-blocking, and we've read all we can
* without blocking.
* - a channel reading error occurs (and we return TCL_INDEX_NONE)
*
* Side effects:
* May cause input to be buffered.
|
| ︙ | ︙ | |||
10094 10095 10096 10097 10098 10099 10100 | ChannelBuffer *bufPtr = statePtr->inQueueHead; /* * Don't read more data if we have what we need. */ while (!bufPtr || /* We got no buffer! OR */ | | < < | < | < | < < < | > > > > > > | 10111 10112 10113 10114 10115 10116 10117 10118 10119 10120 10121 10122 10123 10124 10125 10126 10127 10128 10129 10130 10131 10132 10133 10134 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 10148 10149 10150 10151 10152 10153 10154 10155 10156 10157 |
ChannelBuffer *bufPtr = statePtr->inQueueHead;
/*
* Don't read more data if we have what we need.
*/
while (!bufPtr || /* We got no buffer! OR */
(!IsBufferFull(bufPtr) && /* Our buffer has room AND */
((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) {
/* Not enough bytes in it yet
* to fill the dst */
int code;
moreData:
code = GetInput(chanPtr);
bufPtr = statePtr->inQueueHead;
if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) {
/*
* Further reads cannot do any more.
*/
break;
}
if (code || !bufPtr) {
/* Read error (or channel dead/closed) */
goto readErr;
}
assert(IsBufferFull(bufPtr));
}
if (!bufPtr) {
readErr:
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return -1;
}
bytesRead = BytesLeft(bufPtr);
bytesWritten = bytesToRead;
TranslateInputEOL(statePtr, p, RemovePoint(bufPtr),
&bytesWritten, &bytesRead);
bufPtr->nextRemoved += bytesRead;
|
| ︙ | ︙ | |||
10238 10239 10240 10241 10242 10243 10244 |
}
}
if (bytesToRead == 0) {
ResetFlag(statePtr, CHANNEL_BLOCKED);
}
assert(!GotFlag(statePtr, CHANNEL_EOF)
| | < | 10254 10255 10256 10257 10258 10259 10260 10261 10262 10263 10264 10265 10266 10267 10268 |
}
}
if (bytesToRead == 0) {
ResetFlag(statePtr, CHANNEL_BLOCKED);
}
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF|CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return (Tcl_Size)(p - dst);
}
|
| ︙ | ︙ | |||
10298 10299 10300 10301 10302 10303 10304 |
ChannelState *inStatePtr,
ChannelState *outStatePtr,
long long toRead)
{
return inStatePtr->inEofChar == '\0' /* No eofChar to stop input */
&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF
&& outStatePtr->outputTranslation == TCL_TRANSLATE_LF
| < < | < | < < < | | < | 10313 10314 10315 10316 10317 10318 10319 10320 10321 10322 10323 10324 10325 10326 10327 10328 10329 10330 10331 10332 10333 |
ChannelState *inStatePtr,
ChannelState *outStatePtr,
long long toRead)
{
return inStatePtr->inEofChar == '\0' /* No eofChar to stop input */
&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF
&& outStatePtr->outputTranslation == TCL_TRANSLATE_LF
&& ((inStatePtr->encoding == GetBinaryEncoding()
&& outStatePtr->encoding == GetBinaryEncoding())
|| (toRead == -1
&& inStatePtr->encoding == outStatePtr->encoding
&& ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8
&& ENCODING_PROFILE_GET(outStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8
));
}
/*
*----------------------------------------------------------------------
*
* StopCopy --
*
|
| ︙ | ︙ | |||
10377 10378 10379 10380 10381 10382 10383 10384 |
Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr);
if (inChan != outChan) {
Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr);
}
Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr);
Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr);
TclDecrRefCount(csPtr->cmdPtr);
}
| > > > > | > > > > | > > > > > > > > > > > > > > > | 10385 10386 10387 10388 10389 10390 10391 10392 10393 10394 10395 10396 10397 10398 10399 10400 10401 10402 10403 10404 10405 10406 10407 10408 10409 10410 10411 10412 10413 10414 10415 10416 10417 10418 10419 10420 10421 10422 10423 10424 |
Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr);
if (inChan != outChan) {
Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr);
}
Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr);
Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr);
TclDecrRefCount(csPtr->cmdPtr);
csPtr->cmdPtr = NULL;
}
if (inStatePtr->csPtrR) {
assert(inStatePtr->csPtrR == csPtr);
inStatePtr->csPtrR = NULL;
CopyDecrRefCount(csPtr);
}
if (outStatePtr->csPtrW) {
assert(outStatePtr->csPtrW == csPtr);
outStatePtr->csPtrW = NULL;
CopyDecrRefCount(csPtr);
}
}
static void
CopyDecrRefCount(
CopyState *csPtr)
{
if (csPtr->refCount-- > 1) {
return;
}
TclChannelRelease((Tcl_Channel)csPtr->readPtr);
TclChannelRelease((Tcl_Channel)csPtr->writePtr);
Tcl_Free(csPtr);
}
/*
*----------------------------------------------------------------------
*
* StackSetBlockMode --
|
| ︙ | ︙ | |||
10477 10478 10479 10480 10481 10482 10483 |
* Note that we cannot have a message in the interpreter bypass
* area, StackSetBlockMode is restricted to the channel bypass.
* We still need the interp as the destination of the move.
*/
if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 10520 10521 10522 |
* Note that we cannot have a message in the interpreter bypass
* area, StackSetBlockMode is restricted to the channel bypass.
* We still need the interp as the destination of the move.
*/
if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error setting blocking mode: %s",
Tcl_PosixError(interp)));
}
} else {
/*
* TIP #219.
* If we have no interpreter to put a bypass message into we have
* to clear it, to prevent its propagation and use in other places
|
| ︙ | ︙ | |||
10528 10529 10530 10531 10532 10533 10534 | } /* *---------------------------------------------------------------------- * * Tcl_GetChannelNamesEx -- * | | | 10559 10560 10561 10562 10563 10564 10565 10566 10567 10568 10569 10570 10571 10572 10573 | } /* *---------------------------------------------------------------------- * * Tcl_GetChannelNamesEx -- * * Return the names of open channels in the interp filtered * through a pattern. If pattern is NULL, it returns all the open * channels. * * Results: * TCL_OK or TCL_ERROR. * * Side effects: |
| ︙ | ︙ | |||
10752 10753 10754 10755 10756 10757 10758 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_ChannelName( | | > | 10783 10784 10785 10786 10787 10788 10789 10790 10791 10792 10793 10794 10795 10796 10797 10798 |
* None.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_ChannelName(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
return chanTypePtr->typeName;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
11102 11103 11104 11105 11106 11107 11108 |
iPtr->chanMsg = FixLevelCode(msg);
Tcl_IncrRefCount(iPtr->chanMsg);
} else {
iPtr->chanMsg = NULL;
}
if (disposePtr != NULL) {
| | | 11134 11135 11136 11137 11138 11139 11140 11141 11142 11143 11144 11145 11146 11147 11148 |
iPtr->chanMsg = FixLevelCode(msg);
Tcl_IncrRefCount(iPtr->chanMsg);
} else {
iPtr->chanMsg = NULL;
}
if (disposePtr != NULL) {
TclDecrRefCount(disposePtr);
}
return;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
11129 11130 11131 11132 11133 11134 11135 |
*/
void
Tcl_SetChannelError(
Tcl_Channel chan, /* Channel to store the data into. */
Tcl_Obj *msg) /* Error message to store. */
{
| | | | 11161 11162 11163 11164 11165 11166 11167 11168 11169 11170 11171 11172 11173 11174 11175 11176 11177 11178 11179 11180 11181 11182 11183 11184 11185 11186 |
*/
void
Tcl_SetChannelError(
Tcl_Channel chan, /* Channel to store the data into. */
Tcl_Obj *msg) /* Error message to store. */
{
ChannelState *statePtr = ((Channel *)chan)->state;
Tcl_Obj *disposePtr = statePtr->chanMsg;
if (msg != NULL) {
statePtr->chanMsg = FixLevelCode(msg);
Tcl_IncrRefCount(statePtr->chanMsg);
} else {
statePtr->chanMsg = NULL;
}
if (disposePtr != NULL) {
TclDecrRefCount(disposePtr);
}
return;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
11186 11187 11188 11189 11190 11191 11192 |
* Syntax = (option value)... ?message?
*
* Bad message syntax causes a panic, because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshal the
* information. Hence an error means that we've got serious breakage.
*/
| | | 11218 11219 11220 11221 11222 11223 11224 11225 11226 11227 11228 11229 11230 11231 11232 |
* Syntax = (option value)... ?message?
*
* Bad message syntax causes a panic, because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshal the
* information. Hence an error means that we've got serious breakage.
*/
res = TclListObjGetElements(NULL, msg, &lc, &lv);
if (res != TCL_OK) {
Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
}
explicitResult = (1 == (lc % 2));
numOptions = lc - explicitResult;
|
| ︙ | ︙ |
Changes to generic/tclIO.h.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
Tcl_Size refCount; /* Current uses count */
Tcl_Size nextAdded; /* The next position into which a character
* will be put in the buffer. */
| | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
Tcl_Size refCount; /* Current uses count */
Tcl_Size nextAdded; /* The next position into which a character
* will be put in the buffer. */
Tcl_Size nextRemoved; /* Position of next byte to be removed from
* the buffer. */
Tcl_Size bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real
* buffer occupies this space + bufSize-1
* bytes. This must be the last field in the
* structure. */
} ChannelBuffer;
#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf)
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
* data specific to the channel but which belongs to the generic part of the
* Tcl channel mechanism, and it points at an instance specific (and type
* specific) instance data, and at a channel type structure.
*/
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
| | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
* data specific to the channel but which belongs to the generic part of the
* Tcl channel mechanism, and it points at an instance specific (and type
* specific) instance data, and at a channel type structure.
*/
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
void *instanceData; /* Instance-specific data provided by creator
* of channel. */
const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
* upon. This reference is NULL for normal
* channels. See Tcl_StackChannel. */
struct Channel *upChanPtr; /* Refers to the channel above stacked this
* one. NULL for the top most channel. */
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
TclEolTranslation outputTranslation;
/* What translation to use for generating end
* of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
#if TCL_MAJOR_VERSION < 9
int outEofChar; /* If nonzero, append this to the channel when
| | > | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
TclEolTranslation outputTranslation;
/* What translation to use for generating end
* of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
#if TCL_MAJOR_VERSION < 9
int outEofChar; /* If nonzero, append this to the channel when
* it is closed if it is open for writing.
* For Tcl 8.x only */
#endif
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
Tcl_Size refCount; /* How many interpreters hold references to
* this IO channel? */
struct CloseCallback *closeCbPtr;
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
* handlers for. */
EventScriptRecord *scriptRecordPtr;
/* Chain of all scripts registered for event
* handlers ("fileevent") on this channel. */
Tcl_Size bufSize; /* What size buffers to allocate? */
Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
Channel *timerChanPtr; /* Needed in order to decrement the refCount of
| | | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
* handlers for. */
EventScriptRecord *scriptRecordPtr;
/* Chain of all scripts registered for event
* handlers ("fileevent") on this channel. */
Tcl_Size bufSize; /* What size buffers to allocate? */
Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
Channel *timerChanPtr; /* Needed in order to decrement the refCount of
* the right channel when the timer is
* deleted. */
struct CopyState *csPtrR; /* State of background copy for which channel
* is input, or NULL. */
struct CopyState *csPtrW; /* State of background copy for which channel
* is output, or NULL. */
Channel *topChanPtr; /* Refers to topmost channel in a stack. Never
* NULL. */
Channel *bottomChanPtr; /* Refers to bottommost channel in a stack.
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
/*
* TIP #219 ... Info for the I/O system ...
* Error message set by channel drivers, for the propagation of arbitrary
* Tcl errors. This information, if present (chanMsg not NULL), takes
* precedence over a Posix error code returned by a channel operation.
*/
| | | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
/*
* TIP #219 ... Info for the I/O system ...
* Error message set by channel drivers, for the propagation of arbitrary
* Tcl errors. This information, if present (chanMsg not NULL), takes
* precedence over a Posix error code returned by a channel operation.
*/
Tcl_Obj *chanMsg;
Tcl_Obj *unreportedMsg; /* Non-NULL if an error report was deferred
* because it happened in the background. The
* value is the chanMg, if any. #219's
* companion to 'unreportedError'. */
Tcl_Size epoch; /* Used to test validity of stored channelname
* lookup results. */
int maxPerms; /* TIP #220: Max access privileges
* the channel was created with. */
} ChannelState;
/*
* Values for the flags field in Channel. Any OR'ed combination of the
|
| ︙ | ︙ |
Changes to generic/tclIOCmd.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
/*
* tclIOCmd.c --
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
* Copyright © 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
/*
* Callback structure for accept callback in a TCP server.
*/
typedef struct {
| > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
/*
* tclIOCmd.c --
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
* Copyright © 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclIO.h"
#include "tclTomMath.h"
/*
* Callback structure for accept callback in a TCP server.
*/
typedef struct {
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | static Tcl_ThreadDataKey dataKey; /* * Static functions for this file: */ static Tcl_ExitProc FinalizeIOCmdTSD; | | | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | static Tcl_ThreadDataKey dataKey; /* * Static functions for this file: */ static Tcl_ExitProc FinalizeIOCmdTSD; static Tcl_TcpAcceptProc AcceptCallbackProc; static Tcl_ObjCmdProc ChanPendingObjCmd; static Tcl_ObjCmdProc ChanTruncateObjCmd; static void RegisterTcpServerInterpCleanup( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc; static void TcpServerCloseProc(void *callbackData); static void UnregisterTcpServerInterpCleanupProc( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); /* |
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
chanObjPtr = objv[2];
string = objv[3];
break;
}
/* Fall through */
default: /* [puts] or
* [puts some bad number of arguments...] */
| | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
chanObjPtr = objv[2];
string = objv[3];
break;
}
/* Fall through */
default: /* [puts] or
* [puts some bad number of arguments...] */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channel? string");
return TCL_ERROR;
}
if (chanObjPtr == NULL) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->initialized) {
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *chanObjPtr;
Tcl_Channel chan; /* The channel to flush on. */
int mode;
if (objc != 2) {
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *chanObjPtr;
Tcl_Channel chan; /* The channel to flush on. */
int mode;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
chanObjPtr = objv[1];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_WRITABLE)) {
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
Tcl_Channel chan; /* The channel to read from. */
Tcl_Size lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
int code = TCL_OK;
if ((objc != 2) && (objc != 3)) {
| | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
Tcl_Channel chan; /* The channel to read from. */
Tcl_Size lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
int code = TCL_OK;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channel ?varName?");
return TCL_ERROR;
}
chanObjPtr = objv[1];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_READABLE)) {
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
Tcl_Obj *resultPtr, *chanObjPtr;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
argerror:
iPtr = (Interp *) interp;
| | | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
Tcl_Obj *resultPtr, *chanObjPtr;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
argerror:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv, "channel ?numChars?");
/*
* Do not append directly; that makes ensembles using this command as
* a subcommand produce the wrong message.
*/
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channel");
return TCL_ERROR;
}
i = 1;
newline = 0;
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
newline = 1;
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 |
* Compute how many bytes to read.
*/
toRead = -1;
if (i < objc) {
if ((TclGetWideIntFromObj(NULL, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
| | | | | | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 |
* Compute how many bytes to read.
*/
toRead = -1;
if (i < objc) {
if ((TclGetWideIntFromObj(NULL, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected non-negative integer but got \"%s\"",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL);
return TCL_ERROR;
}
}
TclNewObj(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead == TCL_IO_FAILURE) {
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
Tcl_Size length;
| | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 |
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
Tcl_Size length;
result = TclGetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
TclChannelRelease(chan);
return TCL_OK;
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 |
int optionIndex;
static const char *const originOptions[] = {
"start", "current", "end", NULL
};
static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
| | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 |
int optionIndex;
static const char *const originOptions[] = {
"start", "current", "end", NULL
};
static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channel offset ?origin?");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
if (TclGetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
int code;
if (objc != 2) {
| | < | 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 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
int code;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
/*
* Try to find a channel with the right name and permissions in the IO
* channel table of this interpreter.
*/
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
TclChannelPreserve(chan);
newLoc = Tcl_Tell(chan);
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and put
* them into the regular interpreter result.
*/
code = TclChanCaughtErrorBypass(interp, chan);
TclChannelRelease(chan);
if (code) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 |
Tcl_Channel chan; /* The channel to close. */
static const char *const dirOptions[] = {
"read", "write", NULL
};
static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};
if ((objc != 2) && (objc != 3)) {
| | | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
Tcl_Channel chan; /* The channel to close. */
static const char *const dirOptions[] = {
"read", "write", NULL
};
static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channel ?direction?");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
710 711 712 713 714 715 716 |
const char *string;
Tcl_Size len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
| | | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
const char *string;
Tcl_Size len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
string = TclGetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, len - 1);
}
return TCL_ERROR;
}
return TCL_OK;
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
| | | 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
Tcl_WrongNumArgs(interp, 1, objv, "channel ?-option value ...?");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
if (objc != 2) {
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan)));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* ChanIsBinaryCmd --
*
* This function is invoked to process the Tcl "chan isbinary" command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets interp's result to boolean true or false depending on whether the
* specified channel is a binary channel.
*
*---------------------------------------------------------------------------
*/
static int
ChanIsBinaryCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclChanIsBinary(chan)));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExecObjCmd --
*
* This function is invoked to process the "exec" Tcl command. See the
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 |
/*
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
| | | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
/*
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
string = TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
return result;
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
if (objc != 2) {
| | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_READABLE)) {
|
| ︙ | ︙ | |||
1129 1130 1131 1132 1133 1134 1135 |
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
| | | | | | 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 |
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
int mode, modeFlags;
Tcl_Size cmdObjc;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
return TCL_ERROR;
}
mode = TclGetOpenMode(interp, modeString, &modeFlags);
if (mode == -1) {
chan = NULL;
} else {
int flags = TCL_STDERR | TCL_ENFORCE_MODE;
switch (mode & O_ACCMODE) {
case O_RDONLY:
flags |= TCL_STDOUT;
break;
case O_WRONLY:
flags |= TCL_STDIN;
break;
case O_RDWR:
flags |= (TCL_STDIN | TCL_STDOUT);
break;
default:
Tcl_Panic("Tcl_OpenCmd: invalid mode value");
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
if ((modeFlags & CHANNEL_RAW_MODE) && chan) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
Tcl_Free((void *)cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1804 1805 1806 1807 1808 1809 1810 |
{
Tcl_Channel chan;
static const char *const options[] = {"input", "output", NULL};
enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index;
int mode;
if (objc != 3) {
| | | 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 |
{
Tcl_Channel chan;
static const char *const options[] = {"input", "output", NULL};
enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index;
int mode;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode channel");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1864 1865 1866 1867 1868 1869 1870 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
Tcl_WideInt length;
if ((objc < 2) || (objc > 3)) {
| | | 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
Tcl_WideInt length;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channel ?length?");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 3) {
|
| ︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 |
{"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
{"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */
{"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */
{"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
| > | 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 |
{"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
{"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"isbinary", ChanIsBinaryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */
{"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */
{"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
|
| ︙ | ︙ | |||
2057 2058 2059 2060 2061 2062 2063 |
ensemble = TclMakeEnsemble(interp, "chan", initMap);
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
for (i=0 ; extras[i] ; i+=2) {
/*
* Can assume that reference counts are all incremented.
*/
| | < | 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 |
ensemble = TclMakeEnsemble(interp, "chan", initMap);
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
for (i=0 ; extras[i] ; i+=2) {
/*
* Can assume that reference counts are all incremented.
*/
TclDictPutString(NULL, mapObj, extras[i], extras[i + 1]);
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj);
return ensemble;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIOGT.c.
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
/*
* This structure describes the channel type structure for Tcl-based
* transformations.
*/
static const Tcl_ChannelType transformChannelType = {
| | | | | | | | | | | | | | | | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
/*
* This structure describes the channel type structure for Tcl-based
* transformations.
*/
static const Tcl_ChannelType transformChannelType = {
"transform",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
TransformInputProc,
TransformOutputProc,
NULL, /* Deprecated. */
TransformSetOptionProc,
TransformGetOptionProc,
TransformWatchProc,
TransformGetFileHandleProc,
TransformCloseProc,
TransformBlockModeProc,
NULL, /* Flush proc. */
TransformNotifyProc,
TransformWideSeekProc,
NULL, /* Thread action proc. */
NULL /* Truncate proc. */
};
/*
* Possible values for 'flags' field in control structure, see below.
*/
#define CHANNEL_ASYNC (1<<0) /* Non-blocking mode. */
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
TransformChannelData *dataPtr;
Tcl_DString ds;
if (chan == NULL) {
return TCL_ERROR;
}
| | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
TransformChannelData *dataPtr;
Tcl_DString ds;
if (chan == NULL) {
return TCL_ERROR;
}
if (TCL_OK != TclListObjLength(interp, cmdObjPtr, &objc)) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("-command value is not a list", -1));
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen);
if (resBuf) {
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
}
nonBytes:
Tcl_AppendResult(interp, "chan transform callback received non-bytes",
| | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen);
if (resBuf) {
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
}
nonBytes:
Tcl_AppendResult(interp, "chan transform callback received non-bytes",
(char *)NULL);
Tcl_Release(eval);
return TCL_ERROR;
case TRANSMIT_NUM:
/*
* Interpret result as integer number.
*/
|
| ︙ | ︙ | |||
846 847 848 849 850 851 852 | * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static long long TransformWideSeekProc( | | | | 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
* contains the POSIX error code if an error occurred, or zero.
*
*----------------------------------------------------------------------
*/
static long long
TransformWideSeekProc(
void *instanceData, /* The channel to manipulate. */
long long offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
void *parentData = Tcl_GetChannelInstanceData(parent);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
* If we have a wide seek capability, we should stick with that.
*/
if (parentWideSeekProc == NULL) {
*errorCodePtr = EINVAL;
return -1;
}
| | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
* If we have a wide seek capability, we should stick with that.
*/
if (parentWideSeekProc == NULL) {
*errorCodePtr = EINVAL;
return -1;
}
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* TransformSetOptionProc --
*
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | static void ReflectWatch(void *clientData, int mask); static int ReflectBlock(void *clientData, int mode); #if TCL_THREADS static void ReflectThread(void *clientData, int action); static int ReflectEventRun(Tcl_Event *ev, int flags); static int ReflectEventDelete(Tcl_Event *ev, void *cd); #endif | | < < | | | | | | | | | | | | | | | | | | | | < | < < < < < < < < < < < > > | > | < | 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 |
static void ReflectWatch(void *clientData, int mask);
static int ReflectBlock(void *clientData, int mode);
#if TCL_THREADS
static void ReflectThread(void *clientData, int action);
static int ReflectEventRun(Tcl_Event *ev, int flags);
static int ReflectEventDelete(Tcl_Event *ev, void *cd);
#endif
static long long ReflectSeekWide(void *clientData,
long long offset, int mode, int *errorCodePtr);
static int ReflectGetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static int ReflectTruncate(void *clientData,
long long length);
/*
* The C layer channel type/driver definition used by the reflection.
*/
static const Tcl_ChannelType reflectedChannelType = {
"tclrchannel",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated */
ReflectInput,
ReflectOutput,
NULL, /* Deprecated */
ReflectSetOption,
ReflectGetOption,
ReflectWatch,
NULL, /* Get OS handle from the channel. */
ReflectClose,
ReflectBlock,
NULL, /* Flush channel. */
NULL, /* Handle bubbled events. */
ReflectSeekWide,
#if TCL_THREADS
ReflectThread,
#else
NULL, /* Thread action proc */
#endif
ReflectTruncate /* Truncate proc. */
};
/*
* Instance data for a reflected channel. ===========================
*/
typedef struct {
Tcl_Channel chan; /* Back reference to generic channel
* structure. */
Tcl_Interp *interp; /* Reference to the interpreter containing the
* Tcl level part of the channel. NULL here
* signals the channel is dead because the
* interpreter/thread containing its Tcl
* command is gone. */
#if TCL_THREADS
Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */
Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */
#endif
Tcl_Obj *cmd; /* Callback command prefix */
Tcl_Obj *methods; /* Methods to append to command prefix */
Tcl_Obj *name; /* Name of the channel as created */
int mode; /* Mask of R/W mode */
int interest; /* Mask of events the channel is interested
* in. */
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
/*
* Note regarding the usage of timers.
*
* Most channel implementations need a timer in the C level to ensure that
* data in buffers is flushed out through the generation of fake file
* events.
*
* See 'refchan', 'memchan', etc.
*
* Here this is _not_ required. Interest in events is posted to the Tcl
* level via 'watch'. And posting of events is possible from the Tcl level
* as well, via 'chan postevent'. This means that the generation of all
* events, fake or not, timer based or not, is completely in the hands of
* the Tcl level. Therefore no timer here.
*/
} ReflectedChannel;
/*
* Structure of the table mapping from channel handles to reflected
* channels. Each interpreter which has the handler command for one or more
* reflected channels records them in such a table, so that 'chan postevent'
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
* ForwardParamBase. Where an operation does not need any special types, it
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamInput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* O: Where to store the read bytes */
| | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
* ForwardParamBase. Where an operation does not need any special types, it
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamInput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* O: Where to store the read bytes */
Tcl_Size toRead; /* I: #bytes to read,
* O: #bytes actually read */
};
struct ForwardParamOutput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
const char *buf; /* I: Where the bytes to write come from */
Tcl_Size toWrite; /* I: #bytes to write,
* O: #bytes actually written */
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
Tcl_Obj *rcId; /* Handle of the new channel */
int mode; /* R/W mode of new channel. Has to match
* abilities of handler commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Channel chan; /* Token for the new channel */
Tcl_Obj *modeObj; /* mode in obj form for method call */
| | | | | > | 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 |
Tcl_Obj *rcId; /* Handle of the new channel */
int mode; /* R/W mode of new channel. Has to match
* abilities of handler commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Channel chan; /* Token for the new channel */
Tcl_Obj *modeObj; /* mode in obj form for method call */
Tcl_Size listc; /* Result of 'initialize', and of */
Tcl_Obj **listv; /* its sublist in the 2nd element */
int methIndex; /* Encoded method name */
int result; /* Result code for 'initialize' */
Tcl_Obj *resObj; /* Result data for 'initialize' */
int methods; /* Bitmask for supported methods. */
Channel *chanPtr; /* 'chan' resolved to internal struct. */
Tcl_Obj *err; /* Error message */
ReflectedChannelMap *rcmPtr;
/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
/*
* Syntax: chan create MODE CMDPREFIX
* [0] [1] [2] [3]
*
* Actually: rCreate MODE CMDPREFIX
* [0] [1] [2]
*/
enum ArgIndices {
MODE = 1,
CMD = 2
};
/*
* Number of arguments...
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix");
|
| ︙ | ︙ | |||
608 609 610 611 612 613 614 |
/*
* Verify the result.
* - List, of method names. Convert to mask.
* Check for non-optionals through the mask.
* Compare open mode against optional r/w.
*/
| | | | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
/*
* Verify the result.
* - List, of method names. Convert to mask.
* Check for non-optionals through the mask.
* Compare open mode against optional r/w.
*/
if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
methods = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
methods |= FLAG(methIndex);
listc--;
}
Tcl_DecrRefCount(resObj);
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
| | | | | | | | | | | | | | | | | | | 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 |
methods |= FLAG(methIndex);
listc--;
}
Tcl_DecrRefCount(resObj);
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"read\" method",
TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"write\" method",
TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cget\" but not \"cgetall\"",
TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cgetall\" but not \"cget\"",
TclGetString(cmdObj)));
goto error;
}
Tcl_ResetResult(interp);
/*
* Everything is fine now.
*/
chan = Tcl_CreateChannel(&reflectedChannelType, TclGetString(rcId), rcPtr,
mode);
rcPtr->chan = chan;
TclChannelPreserve(chan);
chanPtr = (Channel *) chan;
if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
/*
* Some of the nullable methods are not supported. We clone the
* channel type, null the associated C functions, and use the result
* as the actual channel type.
*/
Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType));
memcpy(clonePtr, &reflectedChannelType, sizeof(Tcl_ChannelType));
if (!(methods & FLAG(METH_CONFIGURE))) {
clonePtr->setOptionProc = NULL;
}
if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) {
clonePtr->getOptionProc = NULL;
|
| ︙ | ︙ | |||
713 714 715 716 717 718 719 |
clonePtr->truncateProc = NULL;
}
chanPtr->typePtr = clonePtr;
}
/*
| | | 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
clonePtr->truncateProc = NULL;
}
chanPtr->typePtr = clonePtr;
}
/*
* Register the channel in the I/O system, and in our map for 'chan
* postevent'.
*/
Tcl_RegisterChannel(interp, chan);
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
#endif
/*
* Return handle as result of command.
*/
Tcl_SetObjResult(interp,
| | < < < | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 |
#endif
/*
* Return handle as result of command.
*/
Tcl_SetObjResult(interp,
Tcl_NewStringObj(chanPtr->state->channelName, -1));
return TCL_OK;
error:
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
Tcl_Free(rcPtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclChanPostEventObjCmd --
*
|
| ︙ | ︙ | |||
810 811 812 813 814 815 816 |
* latter ensures that no pending events of this type are run on an
* invalid channel.
*/
ReflectEvent *e = (ReflectEvent *) ev;
if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) {
| | | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 |
* latter ensures that no pending events of this type are run on an
* invalid channel.
*/
ReflectEvent *e = (ReflectEvent *) ev;
if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) {
return 0;
}
return 1;
}
#endif
int
TclChanPostEventObjCmd(
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
* [0] [1] [2] [3]
*
* Actually: rPostevent CHANNEL EVENTSPEC
* [0] [1] [2]
*
* where EVENTSPEC = {read write ...} (Abbreviations allowed as well).
*/
| | | | > | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
* [0] [1] [2] [3]
*
* Actually: rPostevent CHANNEL EVENTSPEC
* [0] [1] [2]
*
* where EVENTSPEC = {read write ...} (Abbreviations allowed as well).
*/
enum ArgIndices {
CHAN = 1,
EVENT = 2
};
const char *chanId; /* Tcl level channel handle */
Tcl_Channel chan; /* Channel associated to the handle */
const Tcl_ChannelType *chanTypePtr;
/* Its associated driver structure */
ReflectedChannel *rcPtr; /* Associated instance data */
int events; /* Mask of events to post */
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
chanId = TclGetString(objv[CHAN]);
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 |
chanId = TclGetString(objv[CHAN]);
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can not find reflected channel named \"%s\"", chanId));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, (char *)NULL);
return TCL_ERROR;
}
/*
* Note that the search above subsumes several of the older checks,
* namely:
*
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
/*
* Check that the channel is actually interested in the provided events.
*/
if (events & ~rcPtr->interest) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < | 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 |
/*
* Check that the channel is actually interested in the provided events.
*/
if (events & ~rcPtr->interest) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"tried to post events channel \"%s\" is not interested in",
chanId));
return TCL_ERROR;
}
/*
* We have the channel and the events to post.
*/
#if TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
Tcl_NotifyChannel(chan, events);
#if TCL_THREADS
} else {
ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent));
ev->header.proc = ReflectEventRun;
ev->events = events;
ev->rcPtr = rcPtr;
/*
* We are not preserving the structure here. When the channel is
* closed any pending events are deleted, see ReflectClose(), and
* ReflectEventDelete(). Trying to preserve and later release when the
* event is run may generate a situation where the channel structure
* is deleted but not our structure, crashing in
* FreeReflectedChannel().
*
* Force creation of the RCM, for proper cleanup on thread teardown.
* The teardown of unprocessed events is currently coupled to the
* thread reflected channel map
*/
(void) GetThreadReflectedChannelMap();
/*
* XXX Race condition !!
* XXX The destination thread may not exist anymore already.
* XXX (Delayed postevent executed after channel got removed).
* XXX Can we detect this ? (check the validity of the owner threadid ?)
* XXX Actually, in that case the channel should be dead also !
*/
Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev,
TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
}
#endif
/*
* Squash interp results left by the event script.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
|
| ︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 |
* Syntax = (option value)... ?message?
*
* Bad syntax causes a panic. This is OK because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshal the
* information; if we panic here, something has gone badly wrong already.
*/
| | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
* Syntax = (option value)... ?message?
*
* Bad syntax causes a panic. This is OK because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshal the
* information; if we panic here, something has gone badly wrong already.
*/
if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
return;
}
explicitResult = lc & 1; /* Odd number of values? */
|
| ︙ | ︙ | |||
1203 1204 1205 1206 1207 1208 1209 |
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
| | | | | | < < < < < < | | | | | 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 |
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
/*
* Now squash the pending reflection events for this channel.
*/
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
if (result != TCL_OK) {
FreeReceivedError(&p);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &reflectedChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return EOK;
}
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
/*
* Now squash the pending reflection events for this channel.
*/
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
if (result != TCL_OK) {
PassReceivedErrorInterp(interp, &p);
}
} else {
#endif
result = InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj);
|
| ︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 |
Tcl_GetChannelName(rcPtr->chan));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
| | < < < < < < | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 |
Tcl_GetChannelName(rcPtr->chan));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &reflectedChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 |
Tcl_IncrRefCount(toReadObj);
if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
*errorCodePtr = -code;
| | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 |
Tcl_IncrRefCount(toReadObj);
if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
*errorCodePtr = -code;
goto error;
}
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec);
if (bytev == NULL) {
SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte);
goto invalid;
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
if (p.base.code < 0) {
/*
* No error message, this is an errno signal.
*/
*errorCodePtr = -p.base.code;
} else {
| | | | | 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 |
if (p.base.code < 0) {
/*
* No error message, this is an errno signal.
*/
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
*errorCodePtr = EINVAL;
}
p.output.toWrite = -1;
} else {
*errorCodePtr = EOK;
}
return p.output.toWrite;
}
|
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 |
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
*errorCodePtr = -code;
| | | | | | | | 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 |
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
*errorCodePtr = -code;
goto error;
}
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
if (Tcl_InterpDeleted(rcPtr->interp)) {
/*
* The interp was destroyed during InvokeTclMethod().
*/
SetChannelErrorStr(rcPtr->chan, msg_send_dstlost);
goto invalid;
}
if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
goto invalid;
}
if ((written == 0) && (toWrite > 0)) {
/*
* The handler claims to have written nothing of what it was given.
* That is bad.
*/
SetChannelErrorStr(rcPtr->chan, msg_write_nothing);
goto invalid;
}
if (toWrite < written) {
/*
* The handler claims to have written more than it was given. That is
* bad. Note that the I/O core would crash if we were to return this
* information, trying to write -nnn bytes in the next iteration.
*/
SetChannelErrorStr(rcPtr->chan, msg_write_toomuch);
goto invalid;
}
*errorCodePtr = EOK;
stop:
Tcl_DecrRefCount(bufObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_Release(rcPtr->interp);
|
| ︙ | ︙ | |||
1603 1604 1605 1606 1607 1608 1609 |
/* ASSERT: rcPtr->method & FLAG(METH_SEEK) */
Tcl_Preserve(rcPtr);
TclNewIntObj(offObj, offset);
baseObj = Tcl_NewStringObj(
| | | | | | | 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 |
/* ASSERT: rcPtr->method & FLAG(METH_SEEK) */
Tcl_Preserve(rcPtr);
TclNewIntObj(offObj, offset);
baseObj = Tcl_NewStringObj(
(seekMode == SEEK_SET) ? "start" :
(seekMode == SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
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;
}
*errorCodePtr = EOK;
stop:
Tcl_DecrRefCount(offObj);
Tcl_DecrRefCount(baseObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
|
| ︙ | ︙ | |||
1801 1802 1803 1804 1805 1806 1807 |
void *clientData,
int action)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
switch (action) {
case TCL_CHANNEL_THREAD_INSERT:
| | | | | | | | 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 |
void *clientData,
int action)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
switch (action) {
case TCL_CHANNEL_THREAD_INSERT:
rcPtr->owner = Tcl_GetCurrentThread();
break;
case TCL_CHANNEL_THREAD_REMOVE:
rcPtr->owner = NULL;
break;
default:
Tcl_Panic("Unknown thread action code.");
break;
}
}
#endif
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1967 1968 1969 1970 1971 1972 1973 |
} else {
/*
* Retrieve the value of one option.
*/
method = METH_CGET;
optionObj = Tcl_NewStringObj(optionName, -1);
| | | | | | | | | | | 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 |
} else {
/*
* Retrieve the value of one option.
*/
method = METH_CGET;
optionObj = Tcl_NewStringObj(optionName, -1);
Tcl_IncrRefCount(optionObj);
}
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, method, optionObj, NULL, &resObj)!=TCL_OK) {
UnmarshallErrorResult(interp, resObj);
goto error;
}
/*
* The result has to go into the 'dsPtr' for propagation to the caller of
* the driver.
*/
if (optionObj != NULL) {
TclDStringAppendObj(dsPtr, resObj);
goto ok;
}
/*
* Extract the list and append each item as element.
*/
/*
* NOTE (4): If we extract the string rep we can assume a properly quoted
* string. Together with a separating space this way of simply appending
* the whole string rep might be faster. It also doesn't check if the
* result is a valid list. Nor that the list has an even number elements.
*/
if (TclListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) {
goto error;
}
if ((listc % 2) == 1) {
/*
* 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 = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
Tcl_DStringAppend(dsPtr, str, len);
}
goto ok;
}
ok:
result = TCL_OK;
stop:
if (optionObj) {
Tcl_DecrRefCount(optionObj);
}
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_Release(rcPtr);
return result;
error:
result = TCL_ERROR;
goto stop;
|
| ︙ | ︙ | |||
2144 2145 2146 2147 2148 2149 2150 |
{
int events; /* Mask of events to post */
Tcl_Size listc; /* #elements in eventspec list */
Tcl_Obj **listv; /* Elements of eventspec list */
int evIndex; /* Id of event for an element of the eventspec
* list. */
| | | 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 |
{
int events; /* Mask of events to post */
Tcl_Size listc; /* #elements in eventspec list */
Tcl_Obj **listv; /* Elements of eventspec list */
int evIndex; /* Id of event for an element of the eventspec
* list. */
if (TclListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
events = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], eventOptions,
objName, 0, &evIndex) != TCL_OK) {
|
| ︙ | ︙ | |||
2249 2250 2251 2252 2253 2254 2255 |
rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
| < < | 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 |
rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
|
| ︙ | ︙ | |||
2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 |
resObj = Tcl_ObjPrintf("rc%lu", rcCounter);
rcCounter++;
Tcl_MutexUnlock(&rcCounterMutex);
return resObj;
}
static void
FreeReflectedChannel(
void *blockPtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *) blockPtr;
Channel *chanPtr = (Channel *) rcPtr->chan;
TclChannelRelease((Tcl_Channel)chanPtr);
| > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < | 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 |
resObj = Tcl_ObjPrintf("rc%lu", rcCounter);
rcCounter++;
Tcl_MutexUnlock(&rcCounterMutex);
return resObj;
}
static inline void
CleanRefChannelInstance(
ReflectedChannel *rcPtr)
{
if (rcPtr->name) {
/*
* Reset obj-type (channel is deleted or dead anyway) to avoid leakage
* by cyclic references (see bug [79474c58800cdf94]).
*/
TclFreeInternalRep(rcPtr->name);
Tcl_DecrRefCount(rcPtr->name);
rcPtr->name = NULL;
}
if (rcPtr->methods) {
Tcl_DecrRefCount(rcPtr->methods);
rcPtr->methods = NULL;
}
if (rcPtr->cmd) {
Tcl_DecrRefCount(rcPtr->cmd);
rcPtr->cmd = NULL;
}
}
static void
FreeReflectedChannel(
void *blockPtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *) blockPtr;
Channel *chanPtr = (Channel *) rcPtr->chan;
TclChannelRelease((Tcl_Channel)chanPtr);
CleanRefChannelInstance(rcPtr);
Tcl_Free(rcPtr);
}
/*
*----------------------------------------------------------------------
*
* InvokeTclMethod --
|
| ︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 |
if (resultObjPtr != NULL) {
resObj = Tcl_NewStringObj(msg_dstlost,-1);
*resultObjPtr = resObj;
Tcl_IncrRefCount(resObj);
}
| | | | | | 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 |
if (resultObjPtr != NULL) {
resObj = Tcl_NewStringObj(msg_dstlost,-1);
*resultObjPtr = resObj;
Tcl_IncrRefCount(resObj);
}
/*
* Not touching argOneObj, argTwoObj, they have not been used.
* See the contract as well.
*/
return TCL_ERROR;
}
/*
* Insert method into the callback command, after the command prefix,
* before the channel id.
|
| ︙ | ︙ | |||
2450 2451 2452 2453 2454 2455 2456 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Size cmdLen;
| | | 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Size cmdLen;
const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
"chan handler returned bad code: %d", result));
Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
cmdLen);
|
| ︙ | ︙ | |||
2598 2599 2600 2601 2602 2603 2604 |
static void
MarkDead(
ReflectedChannel *rcPtr)
{
if (rcPtr->dead) {
return;
}
| | < < < < < < < < < < < | 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 |
static void
MarkDead(
ReflectedChannel *rcPtr)
{
if (rcPtr->dead) {
return;
}
CleanRefChannelInstance(rcPtr);
rcPtr->dead = 1;
}
static void
DeleteReflectedChannelMap(
void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
|
| ︙ | ︙ | |||
2681 2682 2683 2684 2685 2686 2687 | continue; } /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. | | | | | | | 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 | continue; } /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. * * Attention: Results may have been detached already, by either the * receiver, or this thread, as part of other parts in the thread * teardown. Such results are ignored. See ticket [b47b176adf] for the * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; /* * Basic crash safety until this routine can get revised [3411310] */ |
| ︙ | ︙ | |||
2834 2835 2836 2837 2838 2839 2840 | continue; } /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. | | | | | | | 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 | continue; } /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. * * Attention: Results may have been detached already, by either the * receiver, or this thread, as part of other parts in the thread * teardown. Such results are ignored. See ticket [b47b176adf] for the * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; /* * Basic crash safety until this routine can get revised [3411310] */ |
| ︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 |
* Notes regarding access to the referenced data.
*
* In principle the data belongs to the originating thread (see
* evPtr->src), however this thread is currently blocked at (*), i.e.,
* quiescent. Because of this we can treat the data as belonging to us,
* without fear of race conditions. I.e. we can read and write as we like.
*
| | | | 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 |
* Notes regarding access to the referenced data.
*
* In principle the data belongs to the originating thread (see
* evPtr->src), however this thread is currently blocked at (*), i.e.,
* quiescent. Because of this we can treat the data as belonging to us,
* without fear of race conditions. I.e. we can read and write as we like.
*
* The only thing we cannot be sure of is the resultPtr. This can be
* NULLed if the originating thread went away while the event is handled
* here now.
*/
ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
ForwardingResult *resultPtr = evPtr->resultPtr;
ReflectedChannel *rcPtr = evPtr->rcPtr;
Tcl_Interp *interp = rcPtr->interp;
ForwardParam *paramPtr = evPtr->param;
Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
/*
* Ignore the event if no one is waiting for its result anymore.
*/
if (!resultPtr) {
|
| ︙ | ︙ | |||
3090 3091 3092 3093 3094 3095 3096 | * We remove the channel from both interpreter and thread maps before * releasing the memory, to prevent future accesses (like by * 'postevent') from finding and dereferencing a dangling pointer. */ rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, | | | | 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 |
* We remove the channel from both interpreter and thread maps before
* releasing the memory, to prevent future accesses (like by
* 'postevent') from finding and dereferencing a dangling pointer.
*/
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
MarkDead(rcPtr);
break;
}
case ForwardedInput: {
Tcl_Obj *toReadObj;
|
| ︙ | ︙ | |||
3140 3141 3142 3143 3144 3145 3146 |
} else {
if (bytec > 0) {
memcpy(paramPtr->input.buf, bytev, bytec);
}
paramPtr->input.toRead = bytec;
}
}
| | | | | | | 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 |
} else {
if (bytec > 0) {
memcpy(paramPtr->input.buf, bytev, bytec);
}
paramPtr->input.toRead = bytec;
}
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(toReadObj);
break;
}
case ForwardedOutput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->output.buf, paramPtr->output.toWrite);
Tcl_IncrRefCount(bufObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
} else {
ForwardSetObjError(paramPtr, resObj);
|
| ︙ | ︙ | |||
3179 3180 3181 3182 3183 3184 3185 |
} else if (written==0 || paramPtr->output.toWrite<written) {
ForwardSetStaticError(paramPtr, msg_write_toomuch);
paramPtr->output.toWrite = -1;
} else {
paramPtr->output.toWrite = written;
}
}
| | | | 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 |
} else if (written==0 || paramPtr->output.toWrite<written) {
ForwardSetStaticError(paramPtr, msg_write_toomuch);
paramPtr->output.toWrite = -1;
} else {
paramPtr->output.toWrite = written;
}
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedSeek: {
Tcl_Obj *offObj;
Tcl_Obj *baseObj;
|
| ︙ | ︙ | |||
3222 3223 3224 3225 3226 3227 3228 |
} else {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
paramPtr->seek.offset = -1;
}
}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 |
} else {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
paramPtr->seek.offset = -1;
}
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(offObj);
Tcl_DecrRefCount(baseObj);
break;
}
case ForwardedWatch: {
Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask);
/* assert maskObj.refCount == 1 */
Tcl_Preserve(rcPtr);
rcPtr->interest = paramPtr->watch.mask;
(void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL);
Tcl_DecrRefCount(maskObj);
Tcl_Release(rcPtr);
break;
}
case ForwardedBlock: {
Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);
Tcl_IncrRefCount(blockObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL,
&resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(blockObj);
break;
}
case ForwardedSetOpt: {
Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1);
Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1);
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj,
&resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(optionObj);
Tcl_DecrRefCount(valueObj);
break;
}
case ForwardedGetOpt: {
/*
* Retrieve the value of one option.
*/
Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1);
Tcl_IncrRefCount(optionObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
} else {
TclDStringAppendObj(paramPtr->getOpt.value, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(optionObj);
break;
}
case ForwardedGetOptAll:
/*
* Retrieve all options.
*/
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){
ForwardSetObjError(paramPtr, resObj);
} else {
/*
* Extract list, validate that it is a list, and #elements. See
* NOTE (4) as well.
*/
Tcl_Size listc;
Tcl_Obj **listv;
if (TclListObjGetElements(interp, resObj, &listc,
&listv) != TCL_OK) {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} 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 = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
}
}
}
Tcl_Release(rcPtr);
break;
case ForwardedTruncate: {
Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length);
Tcl_IncrRefCount(lenObj);
Tcl_Preserve(rcPtr);
|
| ︙ | ︙ | |||
3437 3438 3439 3440 3441 3442 3443 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
| | | 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif
|
| ︙ | ︙ |
Changes to generic/tclIORTrans.c.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | void **handle); static int ReflectNotify(void *clientData, int mask); /* * The C layer channel type/driver definition used by the reflection. */ | | | | | | | | | | | | | | | < | | | | | | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
void **handle);
static int ReflectNotify(void *clientData, int mask);
/*
* The C layer channel type/driver definition used by the reflection.
*/
static const Tcl_ChannelType reflectedTransformType = {
"tclrtransform",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
ReflectInput,
ReflectOutput,
NULL, /* Deprecated. */
ReflectSetOption,
ReflectGetOption,
ReflectWatch,
ReflectHandle,
ReflectClose,
ReflectBlock,
NULL, /* Flush channel. Not used by core. */
ReflectNotify,
ReflectSeekWide,
NULL, /* Thread action proc. */
NULL /* Truncate proc. */
};
/*
* Structure of the buffer to hold transform results to be consumed by higher
* layers upon reading from the channel, plus the functions to manage such.
*/
typedef struct {
unsigned char *buf; /* Reference to the buffer area. */
size_t allocated; /* Allocated size of the buffer area. */
size_t used; /* Number of bytes in the buffer,
* <= allocated. */
} ResultBuffer;
#define ResultLength(r) ((r)->used)
/* static int ResultLength(ResultBuffer *r); */
static inline void ResultClear(ResultBuffer *r);
static inline void ResultInit(ResultBuffer *r);
static inline void ResultAdd(ResultBuffer *r, unsigned char *buf,
size_t toWrite);
static inline size_t ResultCopy(ResultBuffer *r, unsigned char *buf,
size_t toRead);
#define RB_INCREMENT (512)
/*
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
int mode; /* R/W mode of parent, later the new channel.
* Has to match the abilities of the handler
* commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Obj *rtId; /* Handle of the new transform (channel) */
Tcl_Obj *modeObj; /* mode in obj form for method call */
| | | | | > | 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 |
int mode; /* R/W mode of parent, later the new channel.
* Has to match the abilities of the handler
* commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Obj *rtId; /* Handle of the new transform (channel) */
Tcl_Obj *modeObj; /* mode in obj form for method call */
Tcl_Size listc; /* Result of 'initialize', and of */
Tcl_Obj **listv; /* its sublist in the 2nd element */
int methIndex; /* Encoded method name */
int result; /* Result code for 'initialize' */
Tcl_Obj *resObj; /* Result data for 'initialize' */
int methods; /* Bitmask for supported methods. */
ReflectedTransformMap *rtmPtr;
/* Map of reflected transforms with handlers
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
/*
* Syntax: chan push CHANNEL CMDPREFIX
* [0] [1] [2] [3]
*
* Actually: rPush CHANNEL CMDPREFIX
* [0] [1] [2]
*/
enum ArgIndices {
CHAN = 1,
CMD = 2
};
/*
* Number of arguments...
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "channel cmdprefix");
|
| ︙ | ︙ | |||
595 596 597 598 599 600 601 |
/*
* Verify the result.
* - List, of method names. Convert to mask. Check for non-optionals
* through the mask. Compare open mode against optional r/w.
*/
| | | | | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 |
/*
* Verify the result.
* - List, of method names. Convert to mask. Check for non-optionals
* through the mask. Compare open mode against optional r/w.
*/
if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
methods = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 |
methods |= FLAG(methIndex);
listc--;
}
Tcl_DecrRefCount(resObj);
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
| | | | | | | | | | | | | | | | 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 |
methods |= FLAG(methIndex);
listc--;
}
Tcl_DecrRefCount(resObj);
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
TclGetString(cmdObj)));
goto error;
}
/*
* Mode tell us what the parent channel supports. The methods tell us what
* the handler supports. We remove the non-supported bits from the mode
* and check that the channel is not completely inaccessible. Afterward the
* mode tells us which methods are still required, and these methods will
* also be supported by the handler, by design of the check.
*/
if (!HAS(methods, METH_READ)) {
mode &= ~TCL_READABLE;
}
if (!HAS(methods, METH_WRITE)) {
mode &= ~TCL_WRITABLE;
}
if (!mode) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" makes the channel inaccessible",
TclGetString(cmdObj)));
goto error;
}
/*
* The mode and support for it is ok, now check the internal constraints.
*/
if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"drain\" but not \"read\"",
TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"flush\" but not \"write\"",
TclGetString(cmdObj)));
goto error;
}
Tcl_ResetResult(interp);
/*
* Everything is fine now.
*/
rtPtr->methods = methods;
rtPtr->mode = mode;
rtPtr->chan = Tcl_StackChannel(interp, &reflectedTransformType, rtPtr, mode,
rtPtr->parent);
/*
* Register the transform in our map for proper handling of deleted
* interpreters and/or threads.
*/
rtmPtr = GetReflectedTransformMap(interp);
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
|
| ︙ | ︙ | |||
711 712 713 714 715 716 717 |
/*
* We are not going through ReflectClose as we never had a channel
* structure.
*/
Tcl_EventuallyFree(rtPtr, FreeReflectedTransform);
return TCL_ERROR;
| < < < | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
/*
* We are not going through ReflectClose as we never had a channel
* structure.
*/
Tcl_EventuallyFree(rtPtr, FreeReflectedTransform);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclChanPopObjCmd --
*
|
| ︙ | ︙ | |||
748 749 750 751 752 753 754 |
/*
* Syntax: chan pop CHANNEL
* [0] [1] [2]
*
* Actually: rPop CHANNEL
* [0] [1]
*/
| | | > | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 |
/*
* Syntax: chan pop CHANNEL
* [0] [1] [2]
*
* Actually: rPop CHANNEL
* [0] [1]
*/
enum ArgIndices {
CHAN = 1
};
const char *chanId; /* Tcl level channel handle */
Tcl_Channel chan; /* Channel associated to the handle */
int mode; /* Channel r/w mode */
/*
* Number of arguments...
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 |
/*
* Removing transformations is generic, and not restricted to reflected
* transformations.
*/
Tcl_UnstackChannel(interp, chan);
return TCL_OK;
| < < | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 |
/*
* Removing transformations is generic, and not restricted to reflected
* transformations.
*/
Tcl_UnstackChannel(interp, chan);
return TCL_OK;
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
* Syntax = (option value)... ?message?
*
* Bad syntax causes a panic. This is OK because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshall the
* information; if we panic here, something has gone badly wrong already.
*/
| | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
* Syntax = (option value)... ?message?
*
* Bad syntax causes a panic. This is OK because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshall the
* information; if we panic here, something has gone badly wrong already.
*/
if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
return;
}
explicitResult = lc & 1; /* Odd number of values? */
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
goto stop;
}
if (rtPtr->eofPending) {
goto stop;
}
| < | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 |
goto stop;
}
if (rtPtr->eofPending) {
goto stop;
}
/*
* The buffer is exhausted, but the caller wants even more. We now
* have to go to the underlying channel, get more bytes and then
* transform them for delivery. We may not get what we want (full EOF
* or temporarily out of data).
*
* Length (rtPtr->result) == 0, toRead > 0 here. Use 'buf'! as target
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 |
}
} /* else: 'maxRead < 0' == Accept the current value of toRead */
}
if (toRead <= 0) {
goto stop;
}
| < | 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 |
}
} /* else: 'maxRead < 0' == Accept the current value of toRead */
}
if (toRead <= 0) {
goto stop;
}
readBytes = Tcl_ReadRaw(rtPtr->parent,
(char *) Tcl_SetByteArrayLength(bufObj, toRead), toRead);
if (readBytes < 0) {
if (Tcl_InputBlocked(rtPtr->parent) && (gotBytes > 0)) {
/*
|
| ︙ | ︙ | |||
1373 1374 1375 1376 1377 1378 1379 |
* non-NULL...
*/
if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
*errorCodePtr = EINVAL;
curPos = -1;
} else {
| | | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
* non-NULL...
*/
if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
*errorCodePtr = EINVAL;
curPos = -1;
} else {
curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
seekMode, errorCodePtr);
}
if (curPos == -1) {
Tcl_SetErrno(*errorCodePtr);
}
*errorCodePtr = EOK;
Tcl_Release(rtPtr);
|
| ︙ | ︙ | |||
1488 1489 1490 1491 1492 1493 1494 | * Arbitrary, per the parent channel. * *---------------------------------------------------------------------- */ static int ReflectSetOption( | | | 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 |
* Arbitrary, per the parent channel.
*
*----------------------------------------------------------------------
*/
static int
ReflectSetOption(
void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
|
| ︙ | ︙ | |||
1530 1531 1532 1533 1534 1535 1536 | * Arbitrary, per the parent channel. * *---------------------------------------------------------------------- */ static int ReflectGetOption( | | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 |
* Arbitrary, per the parent channel.
*
*----------------------------------------------------------------------
*/
static int
ReflectGetOption(
void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
Tcl_DString *dsPtr) /* String to place the result into */
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
|
| ︙ | ︙ | |||
1641 1642 1643 1644 1645 1646 1647 |
return mask;
}
/*
* Helpers. =========================================================
*/
| < | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 |
return mask;
}
/*
* Helpers. =========================================================
*/
/*
*----------------------------------------------------------------------
*
* DecodeEventMask --
*
* This function takes an internal bitmask of events and constructs the
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 |
/*
* Method placeholder.
*/
/* ASSERT: cmdpfxObj is a Tcl List */
| | | 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 |
/*
* Method placeholder.
*/
/* ASSERT: cmdpfxObj is a Tcl List */
TclListObjGetElements(interp, cmdpfxObj, &listc, &listv);
/*
* See [==] as well.
* Storage for the command prefix and the additional words required for
* the invocation of methods in the command handler.
*
* listv [0] [listc-1] | [listc] [listc+1] |
|
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
Tcl_Size cmdLen;
| | | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
Tcl_Size cmdLen;
const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rtPtr->interp);
Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf(
"chan handler returned bad code: %d", result));
Tcl_LogCommandInfo(rtPtr->interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(cmd);
|
| ︙ | ︙ | |||
2071 2072 2073 2074 2075 2076 2077 |
*----------------------------------------------------------------------
*/
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
| | > | 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 |
*----------------------------------------------------------------------
*/
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
ReflectedTransformMap *rtmPtr = (ReflectedTransformMap *)
Tcl_GetAssocData(interp, RTMKEY, NULL);
if (rtmPtr == NULL) {
rtmPtr = (ReflectedTransformMap *)Tcl_Alloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RTMKEY,
(Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
}
|
| ︙ | ︙ | |||
2104 2105 2106 2107 2108 2109 2110 | * registered in this interpreter. * *---------------------------------------------------------------------- */ static void DeleteReflectedTransformMap( | | | 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 |
* registered in this interpreter.
*
*----------------------------------------------------------------------
*/
static void
DeleteReflectedTransformMap(
void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
ReflectedTransformMap *rtmPtr; /* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedTransform *rtPtr;
#if TCL_THREADS
|
| ︙ | ︙ | |||
2239 2240 2241 2242 2243 2244 2245 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
| | > | 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
tsdPtr->rtmPtr = (ReflectedTransformMap *)
Tcl_Alloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL);
}
return tsdPtr->rtmPtr;
}
|
| ︙ | ︙ | |||
2471 2472 2473 2474 2475 2476 2477 |
* Notes regarding access to the referenced data.
*
* In principle the data belongs to the originating thread (see
* evPtr->src), however this thread is currently blocked at (*), i.e.
* quiescent. Because of this we can treat the data as belonging to us,
* without fear of race conditions. I.e. we can read and write as we like.
*
| | | 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 |
* Notes regarding access to the referenced data.
*
* In principle the data belongs to the originating thread (see
* evPtr->src), however this thread is currently blocked at (*), i.e.
* quiescent. Because of this we can treat the data as belonging to us,
* without fear of race conditions. I.e. we can read and write as we like.
*
* The only thing we cannot be sure of is the resultPtr. This can be
* NULLed if the originating thread went away while the event is handled
* here now.
*/
ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
ForwardingResult *resultPtr = evPtr->resultPtr;
ReflectedTransform *rtPtr = evPtr->rtPtr;
|
| ︙ | ︙ | |||
2768 2769 2770 2771 2772 2773 2774 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
| | | 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
2989 2990 2991 2992 2993 2994 2995 |
*----------------------------------------------------------------------
*/
static inline size_t
ResultCopy(
ResultBuffer *rPtr, /* The buffer to read from */
unsigned char *buf, /* The buffer to copy into */
| | | 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 |
*----------------------------------------------------------------------
*/
static inline size_t
ResultCopy(
ResultBuffer *rPtr, /* The buffer to read from */
unsigned char *buf, /* The buffer to copy into */
size_t toRead) /* Number of requested bytes */
{
int copied;
if (rPtr->used == 0) {
/*
* Nothing to copy in the case of an empty buffer.
*/
|
| ︙ | ︙ |
Changes to generic/tclIOSock.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
#if defined(_WIN32)
/*
* On Windows, we need to do proper Unicode->UTF-8 conversion.
*/
typedef struct {
int initialized;
| | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#if defined(_WIN32)
/*
* On Windows, we need to do proper Unicode->UTF-8 conversion.
*/
typedef struct {
int initialized;
Tcl_DString errorMsg; /* UTF-8 encoded error-message */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#undef gai_strerror
static const char *
gai_strerror(
int code)
|
| ︙ | ︙ | |||
71 72 73 74 75 76 77 |
const char *native;
if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
/*
* Don't bother translating 'proto' to native.
*/
| | > | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
const char *native;
if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
/*
* Don't bother translating 'proto' to native.
*/
if (Tcl_UtfToExternalDStringEx(interp, NULL, string, -1, 0, &ds,
NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
native = Tcl_DStringValue(&ds);
sp = getservbyname(native, proto); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (sp != NULL) {
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
socklen_t len;
int size = size1;
if (size != size1) {
return TCL_ERROR;
}
len = sizeof(int);
| | | | | | 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 |
socklen_t len;
int size = size1;
if (size != size1) {
return TCL_ERROR;
}
len = sizeof(int);
getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF,
(char *) ¤t, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF,
(char *) &size, len);
}
len = sizeof(int);
getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF,
(char *) ¤t, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF,
(char *) &size, len);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
184 185 186 187 188 189 190 |
struct addrinfo *v6head = NULL, *v6ptr = NULL;
char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring;
const char *family = NULL;
Tcl_DString ds;
int result;
if (host != NULL) {
| | > | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
struct addrinfo *v6head = NULL, *v6ptr = NULL;
char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring;
const char *family = NULL;
Tcl_DString ds;
int result;
if (host != NULL) {
if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds,
NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return 0;
}
native = Tcl_DStringValue(&ds);
}
/*
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
if (result != 0) {
*errorMsgPtr =
#ifdef EAI_SYSTEM /* Doesn't exist on Windows */
(result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
#endif /* EAI_SYSTEM */
gai_strerror(result);
| | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
if (result != 0) {
*errorMsgPtr =
#ifdef EAI_SYSTEM /* Doesn't exist on Windows */
(result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
#endif /* EAI_SYSTEM */
gai_strerror(result);
return 0;
}
/*
* Put IPv4 addresses before IPv6 addresses to maximize backwards
* compatibility of [fconfigure -sockname] output.
*
* There might be more elegant/efficient ways to do this.
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
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 |
* Copyright © 2001-2004 Vincent Darley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#ifdef _WIN32
# include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
#ifdef TCL_TEMPLOAD_NO_UNLINK
#ifndef NO_FSTATFS
#include <sys/statfs.h>
#endif
#endif
/*
* struct FilesystemRecord --
*
* An item in a linked list of registered filesystems
*/
typedef struct FilesystemRecord {
| > | | < | < | 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 |
* Copyright © 2001-2004 Vincent Darley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclIO.h"
#ifdef _WIN32
# include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
#ifdef TCL_TEMPLOAD_NO_UNLINK
#ifndef NO_FSTATFS
#include <sys/statfs.h>
#endif
#endif
/*
* struct FilesystemRecord --
*
* An item in a linked list of registered filesystems
*/
typedef struct FilesystemRecord {
void *clientData; /* Client-specific data for the filesystem
* (can be NULL) */
const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */
struct FilesystemRecord *nextPtr;
/* The next registered filesystem, or NULL to
* indicate the end of the list. */
struct FilesystemRecord *prevPtr;
/* The previous filesystem, or NULL to indicate
* the ned of the list */
} FilesystemRecord;
/*
*/
typedef struct {
int initialized;
size_t cwdPathEpoch; /* Compared with the global cwdPathEpoch to
* determine whether cwdPathPtr is stale. */
size_t filesystemEpoch;
Tcl_Obj *cwdPathPtr; /* A private copy of cwdPathPtr. Updated when
* the value is accessed and cwdPathEpoch has
* changed. */
void *cwdClientData;
FilesystemRecord *filesystemList;
size_t claims;
} ThreadSpecificData;
/*
* Forward declarations.
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 | * Functions that support the native filesystem functions listed above. They * are the same for win/unix, and not in tclInt.h because they are and should * be used only here. */ MODULE_SCOPE const char *const tclpFileAttrStrings[]; MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; | < | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | * Functions that support the native filesystem functions listed above. They * are the same for win/unix, and not in tclInt.h because they are and should * be used only here. */ MODULE_SCOPE const char *const tclpFileAttrStrings[]; MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; /* * These these functions are not static either because routines in the native * (win/unix) directories call them or they are actually implemented in those * directories. They should be called from outside Tcl's native filesystem * routines. If we ever built the native filesystem support into a separate * code library, this could actually be enforced. |
| ︙ | ︙ | |||
237 238 239 240 241 242 243 | * Obsolete string-based APIs that should be removed in a future release, * perhaps in Tcl 9. */ /* Obsolete */ int Tcl_Stat( | | > | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
* Obsolete string-based APIs that should be removed in a future release,
* perhaps in Tcl 9.
*/
/* Obsolete */
int
Tcl_Stat(
const char *path, /* Pathname of file to stat (in current system
* encoding). */
struct stat *oldStyleBuf) /* Filled with results of stat call. */
{
int ret;
Tcl_StatBuf buf;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
|
| ︙ | ︙ | |||
324 325 326 327 328 329 330 |
}
return ret;
}
/* Obsolete */
int
Tcl_Access(
| | | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 |
}
return ret;
}
/* Obsolete */
int
Tcl_Access(
const char *path, /* Pathname of file to access (in current
* system encoding). */
int mode) /* Permission setting. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSAccess(pathPtr,mode);
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
tsdPtr->initialized = 0;
}
int
TclFSCwdIsNative(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (tsdPtr->cwdClientData != NULL) {
return 1;
} else {
return 0;
}
}
| > > > > > > | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
tsdPtr->initialized = 0;
}
int
TclFSCwdIsNative(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
/* if not yet initialized - ensure we'll once obtain cwd */
if (!tsdPtr->cwdPathEpoch) {
Tcl_Obj *temp = Tcl_FSGetCwd(NULL);
if (temp) { Tcl_DecrRefCount(temp); }
}
if (tsdPtr->cwdClientData != NULL) {
return 1;
} else {
return 0;
}
}
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
Tcl_Size len1, len2;
const char *str1, *str2;
| | | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
Tcl_Size len1, len2;
const char *str1, *str2;
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(*pathPtrPtr, &len2);
if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
* The values are equal but the objects are different. Cache the
* current structure in place of the old one.
*/
Tcl_DecrRefCount(*pathPtrPtr);
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
void *clientData)
{
Tcl_Size len = 0;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
| | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 |
void *clientData)
{
Tcl_Size len = 0;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
str = TclGetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
}
if (cwdClientData != NULL) {
|
| ︙ | ︙ | |||
840 841 842 843 844 845 846 | * registered filesystems. * *---------------------------------------------------------------------- */ int Tcl_FSRegister( | | | 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
* registered filesystems.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSRegister(
void *clientData, /* Client-specific data for this filesystem. */
const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */
{
FilesystemRecord *newFilesystemPtr;
if (fsPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 |
if (ret == TCL_OK) {
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
* resultPtr and tmpResultPtr are guaranteed to be distinct.
*/
| | | 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 |
if (ret == TCL_OK) {
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
* resultPtr and tmpResultPtr are guaranteed to be distinct.
*/
ret = TclListObjGetElements(interp, tmpResultPtr,
&resLength, &elemsPtr);
for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
ret = Tcl_ListObjAppendElement(interp, resultPtr,
TclFSMakePathRelative(interp, elemsPtr[i], cwd));
}
}
TclDecrRefCount(tmpResultPtr);
|
| ︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 |
static void
FsAddMountsToGlobResult(
Tcl_Obj *resultPtr, /* The current list of matching pathnames. Must
* not be shared. */
Tcl_Obj *pathPtr, /* The directory that was searched. */
const char *pattern, /* Pattern to match mounts against. */
Tcl_GlobTypeData *types) /* Acceptable types. May be NULL. The
| | < | | | 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 |
static void
FsAddMountsToGlobResult(
Tcl_Obj *resultPtr, /* The current list of matching pathnames. Must
* not be shared. */
Tcl_Obj *pathPtr, /* The directory that was searched. */
const char *pattern, /* Pattern to match mounts against. */
Tcl_GlobTypeData *types) /* Acceptable types. May be NULL. The
* directory flag is particularly significant. */
{
Tcl_Size mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
if (mounts == NULL) {
return;
}
if (TclListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
if (TclListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
goto endOfMounts;
}
for (i=0 ; i<mLength ; i++) {
Tcl_Obj *mElt;
Tcl_Size j;
int found = 0;
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 |
* i.e. the representation relative to pathPtr.
*/
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
| | | < | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
* i.e. the representation relative to pathPtr.
*/
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
mount = TclGetStringFromObj(mElt, &mlen);
path = TclGetStringFromObj(norm, &len);
if (path[len-1] == '/') {
/*
* Deal with the root of the volume.
*/
len--;
}
len++; /* account for '/' in the mElt [Bug 1602539] */
mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
}
/*
* Not comparing mounts to mounts, so no need to increment gLength
*/
|
| ︙ | ︙ | |||
1217 1218 1219 1220 1221 1222 1223 | * normalized pathname changes. * * Tcl has no control over (2) and (3), so each registered filesystem must * call Tcl_FSMountsChnaged in each of those circumstances. * * The reason for the exception in 2,3 for the native filesystem is that * the native filesystem claims every file without determining whether | | | 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
* normalized pathname changes.
*
* Tcl has no control over (2) and (3), so each registered filesystem must
* call Tcl_FSMountsChnaged in each of those circumstances.
*
* The reason for the exception in 2,3 for the native filesystem is that
* the native filesystem claims every file without determining whether
* the file exists, or even whether the pathname makes sense.
*
*----------------------------------------------------------------------
*/
void
Tcl_FSMountsChanged(
TCL_UNUSED(const Tcl_Filesystem *) /*fsPtr*/)
|
| ︙ | ︙ | |||
1334 1335 1336 1337 1338 1339 1340 |
* are reserved for VFS use. These names can not conflict with real UNC
* pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
* rfc3986's definition of reg-name.
*
* We check these first to avoid useless calls to the native filesystem's
* normalizePathProc.
*/
| | | | | | > > | > | > | > > < | 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 |
* are reserved for VFS use. These names can not conflict with real UNC
* pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
* rfc3986's definition of reg-name.
*
* We check these first to avoid useless calls to the native filesystem's
* normalizePathProc.
*/
path = TclGetStringFromObj(pathPtr, &i);
if ((i >= 3) && ((path[0] == '/' && path[1] == '/')
|| (path[0] == '\\' && path[1] == '\\'))) {
for (i = 2; ; i++) {
if (path[i] == '\0') {
break;
}
if (path[i] == path[0]) {
break;
}
}
--i;
if (path[i] == ':') {
isVfsPath = 1;
}
}
/*
* Call the the normalizePathProc routine of each registered filesystem.
*/
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
if (!isVfsPath) {
/*
* Find and call the native filesystem handler first if there is one
* because the root of Tcl's filesystem is always a native filesystem
* (i.e., '/' on unix is native).
*/
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
|
| ︙ | ︙ | |||
1408 1409 1410 1411 1412 1413 1414 | } /* *--------------------------------------------------------------------------- * * TclGetOpenMode -- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | < | | | < < | < < | < < | | < | | < | < | > > > > > > > > > > > > > > > | > > > | > > > | > > > > > > > > | > > > | > | > > > > | < > > > | < < > > > > > > | < | | | | < | | | 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 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 |
}
/*
*---------------------------------------------------------------------------
*
* TclGetOpenMode --
*
* Computes a POSIX mode mask for opening a file.
*
* Results:
* The mode to pass to "open", or -1 if an error occurs.
*
* Side effects:
* Sets *modeFlagsPtr to 1 to tell the caller to
* seek to EOF after opening the file, or to 0 otherwise.
*
* Adds CHANNEL_RAW_MODE to *modeFlagsPtr to tell the caller
* to configure the channel as a binary channel.
*
* If there is an error and interp is not NULL, sets
* interpreter result to an error message.
*
* Special note:
* Based on a prototype implementation contributed by Mark Diekhans.
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenMode(
Tcl_Interp *interp, /* Interpreter, possibly NULL, to use for
* error reporting. */
const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
int *modeFlagsPtr)
{
int mode, c, gotRW;
Tcl_Size modeArgc, i;
const char **modeArgv = NULL, *flag;
/*
* Check for the simpler fopen-like access modes like "r" which are
* distinguished from the POSIX access modes by the presence of a
* lower-case first letter.
*/
*modeFlagsPtr = 0;
mode = O_RDONLY;
/*
* Guard against wide characters before using byte-oriented routines.
*/
if (!(modeString[0] & 0x80)
&& islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */
switch (modeString[0]) {
case 'r':
break;
case 'w':
mode = O_WRONLY|O_CREAT|O_TRUNC;
break;
case 'a':
/*
* Add O_APPEND for proper automatic seek-to-end-on-write by the
* OS. [Bug 680143]
*/
mode = O_WRONLY|O_CREAT|O_APPEND;
*modeFlagsPtr |= 1;
break;
default:
goto error;
}
i = 1;
while (i<3 && modeString[i]) {
if (modeString[i] == modeString[i-1]) {
goto error;
}
switch (modeString[i++]) {
case '+':
/*
* Remove O_APPEND so that the seek command works. [Bug
* 1773127]
*/
mode = (mode & ~(O_ACCMODE|O_APPEND)) | O_RDWR;
break;
case 'b':
*modeFlagsPtr |= CHANNEL_RAW_MODE;
break;
default:
goto error;
}
}
if (modeString[i] != 0) {
goto error;
}
return mode;
error:
*modeFlagsPtr = 0;
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"illegal access mode \"%s\"", modeString));
Tcl_SetErrorCode(interp, "TCL", "OPENMODE", "INVALID", (char *)NULL);
}
return -1;
}
/*
* The access modes are specified as a list of POSIX modes like O_CREAT.
*
* Tcl_SplitList must work correctly when interp is NULL.
*/
if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
invAccessMode:
if (interp != NULL) {
Tcl_AddErrorInfo(interp,
"\n while processing open access modes \"");
Tcl_AddErrorInfo(interp, modeString);
Tcl_AddErrorInfo(interp, "\"");
Tcl_SetErrorCode(interp, "TCL", "OPENMODE", "INVALID", (char *)NULL);
}
if (modeArgv) {
Tcl_Free((void *)modeArgv);
}
return -1;
}
gotRW = 0;
for (i = 0; i < modeArgc; i++) {
flag = modeArgv[i];
c = flag[0];
if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
if (gotRW) {
invRW:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid access mode \"%s\": modes RDONLY, "
"RDWR, and WRONLY cannot be combined", flag));
}
goto invAccessMode;
}
mode = (mode & ~O_ACCMODE) | O_RDONLY;
gotRW = 1;
} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
if (gotRW) {
goto invRW;
}
mode = (mode & ~O_ACCMODE) | O_WRONLY;
gotRW = 1;
} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
if (gotRW) {
goto invRW;
}
mode = (mode & ~O_ACCMODE) | O_RDWR;
gotRW = 1;
} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
if (mode & O_APPEND) {
accessFlagRepeated:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" repeated", flag));
}
goto invAccessMode;
}
mode |= O_APPEND;
*modeFlagsPtr |= 1;
} else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
if (mode & O_CREAT) {
goto accessFlagRepeated;
}
mode |= O_CREAT;
} else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
if (mode & O_EXCL) {
goto accessFlagRepeated;
}
mode |= O_EXCL;
} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
#ifdef O_NOCTTY
if (mode & O_NOCTTY) {
goto accessFlagRepeated;
}
mode |= O_NOCTTY;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
goto invAccessMode;
#endif
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#ifdef O_NONBLOCK
if (mode & O_NONBLOCK) {
goto accessFlagRepeated;
}
mode |= O_NONBLOCK;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
goto invAccessMode;
#endif
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
if (mode & O_TRUNC) {
goto accessFlagRepeated;
}
mode |= O_TRUNC;
} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
if (*modeFlagsPtr & CHANNEL_RAW_MODE) {
goto accessFlagRepeated;
}
*modeFlagsPtr |= CHANNEL_RAW_MODE;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid access mode \"%s\": must be APPEND, BINARY, "
"CREAT, EXCL, NOCTTY, NONBLOCK, RDONLY, RDWR, "
"TRUNC, or WRONLY", flag));
}
goto invAccessMode;
}
}
Tcl_Free((void *)modeArgv);
if (!gotRW) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"access mode must include either RDONLY, RDWR, or WRONLY",
-1));
}
return -1;
}
return mode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile --
*
* Reads a file and evaluates it as a script.
*
* Tcl_FSEvalFile is Tcl_FSEvalFileEx without the encodingName argument.
*
* TclNREvalFile is an NRE-enabled version of Tcl_FSEvalFileEx.
*
* Results:
* A standard Tcl result, which is either the result of executing the
* file or an error indicating why the file couldn't be read.
*
|
| ︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 |
int
Tcl_FSEvalFileEx(
Tcl_Interp *interp, /* Interpreter that evaluates the script. */
Tcl_Obj *pathPtr, /* Pathname of the file to process.
* Tilde-substitution is performed on this
* pathname. */
const char *encodingName) /* Either the name of an encoding or NULL to
| | | 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 |
int
Tcl_FSEvalFileEx(
Tcl_Interp *interp, /* Interpreter that evaluates the script. */
Tcl_Obj *pathPtr, /* Pathname of the file to process.
* Tilde-substitution is performed on this
* pathname. */
const char *encodingName) /* Either the name of an encoding or NULL to
* use the utf-8 encoding. */
{
Tcl_Size length;
int result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
const char *string;
|
| ︙ | ︙ | |||
1770 1771 1772 1773 1774 1775 1776 |
goto end;
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
| | | 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 |
goto end;
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = TclGetStringFromObj(objPtr, &length);
/*
* TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
|
| ︙ | ︙ | |||
1797 1798 1799 1800 1801 1802 1803 |
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
| | | | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 |
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
const char *pathString = TclGetStringFromObj(pathPtr, &length);
int limit = 150;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
(overflow ? limit : (int)length), pathString,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
end:
Tcl_DecrRefCount(objPtr);
return result;
}
|
| ︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 |
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
Tcl_Size length;
| | | | | | 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 |
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
Tcl_Size length;
const char *pathString = TclGetStringFromObj(pathPtr, &length);
const int limit = 150;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
(overflow ? limit : (int)length), pathString,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
Tcl_DecrRefCount(objPtr);
return result;
}
|
| ︙ | ︙ | |||
2006 2007 2008 2009 2010 2011 2012 | * this is implemented in the C library as a thread-local value , but this * is *really* unsafe to assume! * * Results: * None. * * Side effects: | | | 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 |
* this is implemented in the C library as a thread-local value , but this
* is *really* unsafe to assume!
*
* Results:
* None.
*
* Side effects:
* Modifies the Tcl error code value.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrno(
int err) /* The new value. */
|
| ︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 |
Tcl_Interp *interp) /* Interpreter to set the errorCode of */
{
const char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
if (interp) {
| | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
Tcl_Interp *interp) /* Interpreter to set the errorCode of */
{
const char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
if (interp) {
Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *)NULL);
}
return msg;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 |
*
*----------------------------------------------------------------------
*/
int
Tcl_FSStat(
Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
| | | 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 |
*
*----------------------------------------------------------------------
*/
int
Tcl_FSStat(
Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
* current system encoding). */
Tcl_StatBuf *buf) /* A buffer to hold the results of the call to
* stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->statProc != NULL) {
return fsPtr->statProc(pathPtr, buf);
|
| ︙ | ︙ | |||
2109 2110 2111 2112 2113 2114 2115 |
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLstat(
Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
| | | 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 |
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLstat(
Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
* current system encoding). */
Tcl_StatBuf *buf) /* Filled with results of that call to stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
if (fsPtr->lstatProc != NULL) {
return fsPtr->lstatProc(pathPtr, buf);
|
| ︙ | ︙ | |||
2146 2147 2148 2149 2150 2151 2152 | * See access documentation. * *---------------------------------------------------------------------- */ int Tcl_FSAccess( | | > | 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 |
* See access documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSAccess(
Tcl_Obj *pathPtr, /* Pathname of file to access (in current
* system encoding). */
int mode) /* Permission setting. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->accessProc != NULL) {
return fsPtr->accessProc(pathPtr, mode);
}
|
| ︙ | ︙ | |||
2183 2184 2185 2186 2187 2188 2189 |
Tcl_Channel
Tcl_FSOpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */
Tcl_Obj *pathPtr, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
int permissions) /* What modes to use if opening the file
| | < < < < < < < < < | | | | | 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 |
Tcl_Channel
Tcl_FSOpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */
Tcl_Obj *pathPtr, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
int permissions) /* What modes to use if opening the file
* involves creating it. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Channel retVal = NULL;
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->openFileChannelProc != NULL) {
int mode, modeFlags;
/*
* Parse the mode to determine whether to seek at the outset
* and/or set the channel into binary mode.
*/
mode = TclGetOpenMode(interp, modeString, &modeFlags);
if (mode == -1) {
return NULL;
}
/*
* Open the file.
*/
retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode,
permissions);
if (retVal == NULL) {
return NULL;
}
/*
* Seek and/or set binary mode as determined above.
*/
if ((modeFlags & 1) && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
< (Tcl_WideInt) 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not seek to end of file while opening \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
}
Tcl_CloseEx(NULL, retVal, 0);
return NULL;
}
if (modeFlags & CHANNEL_RAW_MODE) {
Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
}
return retVal;
}
/*
* File doesn't belong to any filesystem that can open it.
|
| ︙ | ︙ | |||
2479 2480 2481 2482 2483 2484 2485 | /* * It's a non-constant attribute list, so do a literal search. */ Tcl_Size i, objc; Tcl_Obj **objv; | | | 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 |
/*
* It's a non-constant attribute list, so do a literal search.
*/
Tcl_Size i, objc;
Tcl_Obj **objv;
if (TclListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) {
TclDecrRefCount(listObj);
return TCL_ERROR;
}
for (i=0 ; i<objc ; i++) {
if (!strcmp(attributeName, TclGetString(objv[i]))) {
TclDecrRefCount(listObj);
*indexPtr = i;
|
| ︙ | ︙ | |||
2765 2766 2767 2768 2769 2770 2771 |
retVal = fsPtr->internalToNormalizedProc(retCd);
Tcl_IncrRefCount(retVal);
}
if (retVal == NULL) {
/*
| | | 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 |
retVal = fsPtr->internalToNormalizedProc(retCd);
Tcl_IncrRefCount(retVal);
}
if (retVal == NULL) {
/*
* The current directory could not be determined. Reset the
* current direcory to ensure, for example, that 'pwd' does actually
* throw the correct error in Tcl. This is tested for in the test
* suite on unix.
*/
FsUpdateCwd(NULL, NULL);
goto cdDidNotChange;
|
| ︙ | ︙ | |||
2800 2801 2802 2803 2804 2805 2806 | * calling 'Tcl_FSEqualPaths', and in addition avoid a nasty * infinite loop bug when trying to normalize tsdPtr->cwdPathPtr. */ Tcl_Size len1, len2; const char *str1, *str2; | | | | 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 |
* calling 'Tcl_FSEqualPaths', and in addition avoid a nasty
* infinite loop bug when trying to normalize tsdPtr->cwdPathPtr.
*/
Tcl_Size len1, len2;
const char *str1, *str2;
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(norm, &len2);
if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
/*
* The pathname values are equal so retain the old pathname
* object which is probably already shared and free the
* normalized pathname that was just produced.
*/
cdEqual:
|
| ︙ | ︙ | |||
2940 2941 2942 2943 2944 2945 2946 |
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
cd = proc2(oldcd);
if (cd != oldcd) {
/*
* Call getCwdProc() and store the resulting internal handle to
| | | 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 |
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
cd = proc2(oldcd);
if (cd != oldcd) {
/*
* Call getCwdProc() and store the resulting internal handle to
* compare things with it later. This might not be
* exactly the same string as that of the fully normalized
* pathname. For example, for the Windows internal handle the
* separator is the backslash character. On Unix it might well
* be true that the internal handle is the fully normalized
* pathname and one could simply use:
* cd = Tcl_FSGetNativePath(pathPtr);
* but this can't be guaranteed in the general case. In fact,
|
| ︙ | ︙ | |||
3008 3009 3010 3011 3012 3013 3014 |
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
| | | | 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 |
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic
* shared object. */
const char *sym1, const char *sym2,
/* Names of two functions to find in the
* dynamic shared object. */
Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr,
/* Places to store pointers to the functions
* named by sym1 and sym2. */
Tcl_LoadHandle *handlePtr, /* A place to store the token for the loaded
|
| ︙ | ︙ | |||
3097 3098 3099 3100 3101 3102 3103 |
Tcl_Obj *shlibFile)
{
/*
* Unlinking is not performed in the following cases:
*
* 1. The operating system is HPUX.
*
| | | | | < | 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 |
Tcl_Obj *shlibFile)
{
/*
* Unlinking is not performed in the following cases:
*
* 1. The operating system is HPUX.
*
* 2. If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and
* set to true (an integer > 0)
*
* 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS
* filesystem can be detected (using statfs, if available).
*/
#ifdef hpux
(void)shlibFile;
return 1;
#else
WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
|
| ︙ | ︙ | |||
3226 3227 3228 3229 3230 3231 3232 |
/*
* The platform supports loading a dynamic shared object from memory.
* Create a sufficiently large buffer, read the file into it, and then load
* the dynamic shared object from the buffer:
*/
{
| > | | < < < < < < < > > > | | < < < | 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 |
/*
* The platform supports loading a dynamic shared object from memory.
* Create a sufficiently large buffer, read the file into it, and then load
* the dynamic shared object from the buffer:
*/
{
Tcl_Size ret;
size_t size;
void *buffer;
Tcl_StatBuf statBuf;
Tcl_Channel data;
ret = Tcl_FSStat(pathPtr, &statBuf);
if (ret < 0) {
goto mustCopyToTempAnyway;
}
size = statBuf.st_size;
data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666);
if (!data) {
if (interp) {
Tcl_ResetResult(interp);
}
goto mustCopyToTempAnyway;
}
buffer = TclpLoadMemoryGetBuffer(size);
if (!buffer) {
Tcl_CloseEx(interp, data, 0);
goto mustCopyToTempAnyway;
}
ret = Tcl_Read(data, (char *)buffer, size);
Tcl_CloseEx(interp, data, 0);
ret = TclpLoadMemory(buffer, size, ret, TclGetString(pathPtr), handlePtr,
&unloadProcPtr, flags);
if (ret == TCL_OK && *handlePtr != NULL) {
goto resolveSymbols;
}
}
mustCopyToTempAnyway:
#endif /* TCL_LOAD_FROM_MEMORY */
/*
* Get a temporary filename, first to copy the file into, and then to load.
*/
copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
|
| ︙ | ︙ | |||
3458 3459 3460 3461 3462 3463 3464 | * from the virtual filesystem to a native filesystem. * *---------------------------------------------------------------------- */ static void * DivertFindSymbol( | | | 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 |
* from the virtual filesystem to a native filesystem.
*
*----------------------------------------------------------------------
*/
static void *
DivertFindSymbol(
Tcl_Interp *interp, /* The relevant interpreter. */
Tcl_LoadHandle loadHandle, /* A handle to the diverted module. */
const char *symbol) /* The name of symbol to resolve. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;
return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol);
|
| ︙ | ︙ | |||
3509 3510 3511 3512 3513 3514 3515 |
/*
* Determine which filesystem contains the temporary copy of the file.
*/
if (tvdlPtr->divertedFilesystem == NULL) {
/*
| | | 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 |
/*
* Determine which filesystem contains the temporary copy of the file.
*/
if (tvdlPtr->divertedFilesystem == NULL) {
/*
* Use the function for the native filsystem, which works even at
* this late stage.
*/
TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
} else {
/*
|
| ︙ | ︙ | |||
3572 3573 3574 3575 3576 3577 3578 |
*----------------------------------------------------------------------
*/
void *
Tcl_FindSymbol(
Tcl_Interp *interp, /* The relevant interpreter. */
Tcl_LoadHandle loadHandle, /* A handle for the loaded object. */
| | | 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 |
*----------------------------------------------------------------------
*/
void *
Tcl_FindSymbol(
Tcl_Interp *interp, /* The relevant interpreter. */
Tcl_LoadHandle loadHandle, /* A handle for the loaded object. */
const char *symbol) /* The name of the symbol to resolve. */
{
return loadHandle->findSymbolProcPtr(interp, loadHandle, symbol);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3643 3644 3645 3646 3647 3648 3649 |
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSLink(
Tcl_Obj *pathPtr, /* Pathaname of file. */
| < | < | 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 |
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSLink(
Tcl_Obj *pathPtr, /* Pathaname of file. */
Tcl_Obj *toPtr, /* NULL or the pathname of a file to link to. */
int linkAction) /* Action to perform. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr) {
if (fsPtr->linkProc == NULL) {
Tcl_SetErrno(ENOTSUP);
|
| ︙ | ︙ | |||
3794 3795 3796 3797 3798 3799 3800 | * * Side effects: * If lenPtr is not null, sets it to the number of elements in the result. * *--------------------------------------------------------------------------- */ | < | 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 |
*
* Side effects:
* If lenPtr is not null, sets it to the number of elements in the result.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSSplitPath(
Tcl_Obj *pathPtr, /* The pathname to split. */
Tcl_Size *lenPtr) /* A place to hold the number of pathname
* elements. */
{
Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */
|
| ︙ | ︙ | |||
3858 3859 3860 3861 3862 3863 3864 |
while ((*p != '\0') && (*p != separator)) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
| | | | | 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 |
while ((*p != '\0') && (*p != separator)) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
nextElt = Tcl_NewStringObj(elementStart, length);
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*p++ == '\0') {
break;
}
}
if (lenPtr != NULL) {
TclListObjLength(NULL, result, lenPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclGetPathType --
|
| ︙ | ︙ | |||
3895 3896 3897 3898 3899 3900 3901 |
Tcl_PathType
TclGetPathType(
Tcl_Obj *pathPtr, /* Pathname to determine type of. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place in which to store a
* pointer to the filesystem for this pathname
* if it is absolute. */
| | > | | 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 |
Tcl_PathType
TclGetPathType(
Tcl_Obj *pathPtr, /* Pathname to determine type of. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place in which to store a
* pointer to the filesystem for this pathname
* if it is absolute. */
Tcl_Size *driveNameLengthPtr,
/* If not NULL, a place in which to store the
* length of the volume name. */
Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a
* place to store a pointer to an object with a
* refCount of 1, and whose value is the name
* of the volume. */
{
Tcl_Size pathLen;
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
driveNameLengthPtr, driveNameRef);
if (type != TCL_PATH_ABSOLUTE) {
type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
|
| ︙ | ︙ | |||
3949 3950 3951 3952 3953 3954 3955 |
TclFSNonnativePathType(
const char *path, /* Pathname to determine the type of. */
Tcl_Size pathLen, /* Length of the pathname. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place to store a pointer to
* the filesystem for this pathname when it is
* an absolute pathname. */
| | > | < | | | | | 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 |
TclFSNonnativePathType(
const char *path, /* Pathname to determine the type of. */
Tcl_Size pathLen, /* Length of the pathname. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place to store a pointer to
* the filesystem for this pathname when it is
* an absolute pathname. */
Tcl_Size *driveNameLengthPtr,
/* If not NULL, a place to store the length of
* the volume name if the pathname is absolute. */
Tcl_Obj **driveNameRef) /* If not NULL, a place to store a pointer to
* an object having its refCount already
* incremented, and contining the name of the
* volume if the pathname is absolute. */
{
FilesystemRecord *fsRecPtr;
Tcl_PathType type = TCL_PATH_RELATIVE;
/*
* Determine whether the given pathname is an absolute pathname on some
* filesystem other than the native filesystem.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
/*
* Skip the native filesystem because otherwise some of the tests
* in the Tcl testsuite might fail because some of the tests
* artificially change the current platform (between win, unix) but the
* list of volumes obtained by calling fsRecPtr->fsPtr->listVolumesProc
* reflects the current (real) platform only. In particular, on Unix
* '/' matchs the beginning of certain absolute Windows pathnames
* starting '//' and those tests go wrong.
*
* There is another reason to skip the native filesystem: Since the
* tclFilename.c code has nice fast 'absolute path' checkers, there is
* no reason to waste time doing that in this frequently-called
* function. It is better to save the overhead of the native
* filesystem continuously returning a list of volumes.
*/
if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
&& (fsRecPtr->fsPtr->listVolumesProc != NULL)) {
Tcl_Size numVolumes;
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
if (TclListObjLength(NULL, thisFsVolumes, &numVolumes)
!= TCL_OK) {
/*
* This is VERY bad; the listVolumesProc didn't return a
* valid list. Set numVolumes to -1 to skip the loop below
* and just return with the current value of 'type'.
*
* It would be better to signal an error here, but
* Tcl_Panic seems a bit excessive.
*/
numVolumes = TCL_INDEX_NONE;
}
while (numVolumes > 0) {
Tcl_Obj *vol;
Tcl_Size len;
const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
if (strncmp(strVol, path, len) == 0) {
type = TCL_PATH_ABSOLUTE;
if (filesystemPtrPtr != NULL) {
*filesystemPtrPtr = fsRecPtr->fsPtr;
|
| ︙ | ︙ | |||
4032 4033 4034 4035 4036 4037 4038 |
}
break;
}
}
Tcl_DecrRefCount(thisFsVolumes);
if (type == TCL_PATH_ABSOLUTE) {
/*
| | | 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 |
}
break;
}
}
Tcl_DecrRefCount(thisFsVolumes);
if (type == TCL_PATH_ABSOLUTE) {
/*
* No need to examine additional filesystems.
*/
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
|
| ︙ | ︙ | |||
4067 4068 4069 4070 4071 4072 4073 |
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRenameFile(
Tcl_Obj *srcPathPtr, /* The pathname of a file or directory to be
| | | 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 |
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRenameFile(
Tcl_Obj *srcPathPtr, /* The pathname of a file or directory to be
* renamed. */
Tcl_Obj *destPathPtr) /* The new pathname for the file. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
|
| ︙ | ︙ | |||
4283 4284 4285 4286 4287 4288 4289 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * | | | 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * * If both pathnames correspond to the same filesystem, calls * 'copyDirectoryProc' of that filesystem. * * Results: * A standard Tcl return code, or -1 if no 'copyDirectoryProc' is found. * * Side effects: * A directory may be copied. POSIX error 'EXDEV' is set if no |
| ︙ | ︙ | |||
4342 4343 4344 4345 4346 4347 4348 | * removeDirectoryProc is found. * *--------------------------------------------------------------------------- */ int Tcl_FSRemoveDirectory( | | < | | < | | | 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 |
* removeDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRemoveDirectory(
Tcl_Obj *pathPtr, /* The pathname of the directory to be removed. */
int recursive, /* If zero, removes only an empty directory.
* Otherwise, removes the directory and all its
* contents. */
Tcl_Obj **errorPtr) /* If not NULL and an error occurs, stores a
* place to store a pointer to a new
* object having a refCount of 1 and containing
* the name of the file that produced an error. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
}
if (fsPtr->removeDirectoryProc == NULL) {
Tcl_SetErrno(ENOTSUP);
return -1;
}
if (recursive) {
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
if (cwdPtr != NULL) {
const char *cwdStr, *normPathStr;
Tcl_Size cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
normPathStr = TclGetStringFromObj(normPath, &normLen);
cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen);
if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
normLen) == 0)) {
/*
* The cwd is inside the directory to be removed. Change
* the cwd to [file dirname $path].
*/
|
| ︙ | ︙ |
Added generic/tclIcu.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 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 |
/*
* tclIcu.c --
*
* tclIcu.c implements various Tcl commands that make use of
* the ICU library if present on the system.
* (Adapted from tkIcu.c)
*
* Copyright © 2021 Jan Nijtmans
* Copyright © 2024 Ashok P. Nadkarni
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
typedef uint16_t UCharx;
typedef uint32_t UChar32x;
/*
* Runtime linking of libicu.
*/
typedef enum UBreakIteratorTypex {
UBRK_CHARACTERX = 0,
UBRK_WORDX = 1
} UBreakIteratorTypex;
typedef enum UErrorCodex {
U_STRING_NOT_TERMINATED_WARNING = -124,
U_AMBIGUOUS_ALIAS_WARNING = -122,
U_ZERO_ERRORZ = 0, /**< No error, no warning. */
U_BUFFER_OVERFLOW_ERROR = 15,
} UErrorCodex;
#define U_SUCCESS(x) ((x)<=U_ZERO_ERRORZ)
#define U_FAILURE(x) ((x)>U_ZERO_ERRORZ)
typedef enum {
UCNV_UNASSIGNED = 0,
UCNV_ILLEGAL = 1,
UCNV_IRREGULAR = 2,
UCNV_RESET = 3,
UCNV_CLOSE = 4,
UCNV_CLONE = 5
} UConverterCallbackReasonx;
typedef enum UNormalizationCheckResultx {
UNORM_NO,
UNORM_YES,
UNORM_MAYBE
} UNormalizationCheckResultx;
typedef struct UEnumeration UEnumeration;
typedef struct UCharsetDetector UCharsetDetector;
typedef struct UCharsetMatch UCharsetMatch;
typedef struct UBreakIterator UBreakIterator;
typedef struct UNormalizer2 UNormalizer2;
typedef struct UConverter UConverter;
typedef struct UConverterFromUnicodeArgs UConverterFromUnicodeArgs;
typedef struct UConverterToUnicodeArgs UConverterToUnicodeArgs;
typedef void (*UConverterFromUCallback)(const void *context,
UConverterFromUnicodeArgs *args,
const UCharx *codeUnits,
int32_t length, UChar32x codePoint,
UConverterCallbackReasonx reason,
UErrorCodex *pErrorCode);
typedef void (*UConverterToUCallback)(const void *context,
UConverterToUnicodeArgs *args,
const char *codeUnits,
int32_t length,
UConverterCallbackReasonx reason,
UErrorCodex *pErrorCode);
/*
* Prototypes for ICU functions sorted by category.
*/
typedef void (*fn_u_cleanup)(void);
typedef const char *(*fn_u_errorName)(UErrorCodex);
typedef UCharx *(*fn_u_strFromUTF32)(UCharx *dest,
int32_t destCapacity,
int32_t *pDestLength,
const UChar32x *src,
int32_t srcLength,
UErrorCodex *pErrorCode);
typedef UCharx *(*fn_u_strFromUTF32WithSub)(UCharx *dest,
int32_t destCapacity,
int32_t *pDestLength,
const UChar32x *src,
int32_t srcLength,
UChar32x subchar,
int32_t *pNumSubstitutions,
UErrorCodex *pErrorCode);
typedef UChar32x *(*fn_u_strToUTF32)(UChar32x *dest,
int32_t destCapacity,
int32_t *pDestLength,
const UCharx *src,
int32_t srcLength,
UErrorCodex *pErrorCode);
typedef UChar32x *(*fn_u_strToUTF32WithSub)(UChar32x *dest,
int32_t destCapacity,
int32_t *pDestLength,
const UCharx *src,
int32_t srcLength,
UChar32x subchar,
int32_t *pNumSubstitutions,
UErrorCodex *pErrorCode);
typedef void (*fn_ucnv_close)(UConverter *);
typedef uint16_t (*fn_ucnv_countAliases)(const char *, UErrorCodex *);
typedef int32_t (*fn_ucnv_countAvailable)(void);
typedef int32_t (*fn_ucnv_fromUChars)(UConverter *, char *dest,
int32_t destCapacity, const UCharx *src, int32_t srcLen, UErrorCodex *);
typedef const char *(*fn_ucnv_getAlias)(const char *, uint16_t, UErrorCodex *);
typedef const char *(*fn_ucnv_getAvailableName)(int32_t);
typedef UConverter *(*fn_ucnv_open)(const char *converterName, UErrorCodex *);
typedef void (*fn_ucnv_setFromUCallBack)(UConverter *,
UConverterFromUCallback newAction,
const void *newContext,
UConverterFromUCallback *oldAction,
const void **oldContext,
UErrorCodex *err);
typedef void (*fn_ucnv_setToUCallBack)(UConverter *,
UConverterToUCallback newAction,
const void *newContext,
UConverterToUCallback *oldAction,
const void **oldContext,
UErrorCodex *err);
typedef int32_t (*fn_ucnv_toUChars)(UConverter *, UCharx *dest,
int32_t destCapacity, const char *src, int32_t srcLen, UErrorCodex *);
typedef UConverterFromUCallback fn_UCNV_FROM_U_CALLBACK_STOP;
typedef UConverterToUCallback fn_UCNV_TO_U_CALLBACK_STOP;
typedef UBreakIterator *(*fn_ubrk_open)(
UBreakIteratorTypex, const char *, const uint16_t *, int32_t,
UErrorCodex *);
typedef void (*fn_ubrk_close)(UBreakIterator *);
typedef int32_t (*fn_ubrk_preceding)(UBreakIterator *, int32_t);
typedef int32_t (*fn_ubrk_following)(UBreakIterator *, int32_t);
typedef int32_t (*fn_ubrk_previous)(UBreakIterator *);
typedef int32_t (*fn_ubrk_next)(UBreakIterator *);
typedef void (*fn_ubrk_setText)(
UBreakIterator *, const void *, int32_t, UErrorCodex *);
typedef UCharsetDetector * (*fn_ucsdet_open)(UErrorCodex *status);
typedef void (*fn_ucsdet_close)(UCharsetDetector *ucsd);
typedef void (*fn_ucsdet_setText)(UCharsetDetector *ucsd,
const char *textIn, int32_t len, UErrorCodex *status);
typedef const char * (*fn_ucsdet_getName)(
const UCharsetMatch *ucsm, UErrorCodex *status);
typedef UEnumeration * (*fn_ucsdet_getAllDetectableCharsets)(
UCharsetDetector *ucsd, UErrorCodex *status);
typedef const UCharsetMatch * (*fn_ucsdet_detect)(
UCharsetDetector *ucsd, UErrorCodex *status);
typedef const UCharsetMatch ** (*fn_ucsdet_detectAll)(
UCharsetDetector *ucsd, int32_t *matchesFound, UErrorCodex *status);
typedef void (*fn_uenum_close)(UEnumeration *);
typedef int32_t (*fn_uenum_count)(UEnumeration *, UErrorCodex *);
typedef const char *(*fn_uenum_next)(UEnumeration *, int32_t *, UErrorCodex *);
typedef UNormalizer2 *(*fn_unorm2_getNFCInstance)(UErrorCodex *);
typedef UNormalizer2 *(*fn_unorm2_getNFDInstance)(UErrorCodex *);
typedef UNormalizer2 *(*fn_unorm2_getNFKCInstance)(UErrorCodex *);
typedef UNormalizer2 *(*fn_unorm2_getNFKDInstance)(UErrorCodex *);
typedef int32_t (*fn_unorm2_normalize)(const UNormalizer2 *,
const UCharx *,
int32_t,
UCharx *,
int32_t,
UErrorCodex *);
#define FIELD(name) fn_ ## name _ ## name
static struct {
size_t nopen; /* Total number of references to ALL libraries */
/*
* Depending on platform, ICU symbols may be distributed amongst
* multiple libraries. For current functionality at most 2 needed.
* Order of library loading is not guaranteed.
*/
Tcl_LoadHandle libs[2];
FIELD(u_cleanup);
FIELD(u_errorName);
FIELD(u_strFromUTF32);
FIELD(u_strFromUTF32WithSub);
FIELD(u_strToUTF32);
FIELD(u_strToUTF32WithSub);
FIELD(ubrk_open);
FIELD(ubrk_close);
FIELD(ubrk_preceding);
FIELD(ubrk_following);
FIELD(ubrk_previous);
FIELD(ubrk_next);
FIELD(ubrk_setText);
FIELD(ucnv_close);
FIELD(ucnv_countAliases);
FIELD(ucnv_countAvailable);
FIELD(ucnv_fromUChars);
FIELD(ucnv_getAlias);
FIELD(ucnv_getAvailableName);
FIELD(ucnv_open);
FIELD(ucnv_setFromUCallBack);
FIELD(ucnv_setToUCallBack);
FIELD(ucnv_toUChars);
FIELD(UCNV_FROM_U_CALLBACK_STOP);
FIELD(UCNV_TO_U_CALLBACK_STOP);
FIELD(ucsdet_close);
FIELD(ucsdet_detect);
FIELD(ucsdet_detectAll);
FIELD(ucsdet_getAllDetectableCharsets);
FIELD(ucsdet_getName);
FIELD(ucsdet_open);
FIELD(ucsdet_setText);
FIELD(uenum_close);
FIELD(uenum_count);
FIELD(uenum_next);
FIELD(unorm2_getNFCInstance);
FIELD(unorm2_getNFDInstance);
FIELD(unorm2_getNFKCInstance);
FIELD(unorm2_getNFKDInstance);
FIELD(unorm2_normalize);
} icu_fns = {
0, {NULL, NULL}, /* Reference count, library handles */
NULL, NULL, NULL, NULL, NULL, NULL, /* u_* */
NULL, NULL, NULL, NULL, NULL, NULL, NULL, /* ubrk* */
NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, /* ucnv_* .. */
NULL, NULL, NULL, /* .. ucnv_ */
NULL, NULL, NULL, NULL, NULL, NULL, NULL, /* ucsdet* */
NULL, NULL, NULL, /* uenum_* */
NULL, NULL, NULL, NULL, NULL, /* unorm2_* */
};
#define u_cleanup icu_fns._u_cleanup
#define u_errorName icu_fns._u_errorName
#define u_strFromUTF32 icu_fns._u_strFromUTF32
#define u_strFromUTF32WithSub icu_fns._u_strFromUTF32WithSub
#define u_strToUTF32 icu_fns._u_strToUTF32
#define u_strToUTF32WithSub icu_fns._u_strToUTF32WithSub
#define ubrk_open icu_fns._ubrk_open
#define ubrk_close icu_fns._ubrk_close
#define ubrk_preceding icu_fns._ubrk_preceding
#define ubrk_following icu_fns._ubrk_following
#define ubrk_previous icu_fns._ubrk_previous
#define ubrk_next icu_fns._ubrk_next
#define ubrk_setText icu_fns._ubrk_setText
#define ucnv_close icu_fns._ucnv_close
#define ucnv_countAliases icu_fns._ucnv_countAliases
#define ucnv_countAvailable icu_fns._ucnv_countAvailable
#define ucnv_fromUChars icu_fns._ucnv_fromUChars
#define ucnv_getAlias icu_fns._ucnv_getAlias
#define ucnv_getAvailableName icu_fns._ucnv_getAvailableName
#define ucnv_open icu_fns._ucnv_open
#define ucnv_setFromUCallBack icu_fns._ucnv_setFromUCallBack
#define ucnv_setToUCallBack icu_fns._ucnv_setToUCallBack
#define ucnv_toUChars icu_fns._ucnv_toUChars
#define UCNV_FROM_U_CALLBACK_STOP icu_fns._UCNV_FROM_U_CALLBACK_STOP
#define UCNV_TO_U_CALLBACK_STOP icu_fns._UCNV_TO_U_CALLBACK_STOP
#define ucsdet_close icu_fns._ucsdet_close
#define ucsdet_detect icu_fns._ucsdet_detect
#define ucsdet_detectAll icu_fns._ucsdet_detectAll
#define ucsdet_getAllDetectableCharsets icu_fns._ucsdet_getAllDetectableCharsets
#define ucsdet_getName icu_fns._ucsdet_getName
#define ucsdet_open icu_fns._ucsdet_open
#define ucsdet_setText icu_fns._ucsdet_setText
#define uenum_next icu_fns._uenum_next
#define uenum_close icu_fns._uenum_close
#define uenum_count icu_fns._uenum_count
#define unorm2_getNFCInstance icu_fns._unorm2_getNFCInstance
#define unorm2_getNFDInstance icu_fns._unorm2_getNFDInstance
#define unorm2_getNFKCInstance icu_fns._unorm2_getNFKCInstance
#define unorm2_getNFKDInstance icu_fns._unorm2_getNFKDInstance
#define unorm2_normalize icu_fns._unorm2_normalize
TCL_DECLARE_MUTEX(icu_mutex);
/* Options used by multiple normalization functions */
static const char *normalizationForms[] = {"nfc", "nfd", "nfkc", "nfkd", NULL};
typedef enum { MODE_NFC, MODE_NFD, MODE_NFKC, MODE_NFKD } NormalizationMode;
/* Error handlers. */
static int
FunctionNotAvailableError(
Tcl_Interp *interp)
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ICU function not available", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ICU", "UNSUPPORTED_OP", NULL);
}
return TCL_ERROR;
}
static int
IcuError(
Tcl_Interp *interp,
const char *message,
UErrorCodex code)
{
if (interp) {
const char *codeMessage = NULL;
if (u_errorName) {
codeMessage = u_errorName(code);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s%sICU error (%d): %s",
message ? message : "",
message ? ". " : "",
code,
codeMessage ? codeMessage : ""));
Tcl_SetErrorCode(interp, "TCL", "ICU", codeMessage, NULL);
}
return TCL_ERROR;
}
/*
* Detect the likely encoding of the string encoded in the given byte array.
*/
static int
DetectEncoding(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int all)
{
Tcl_Size len;
const char *bytes;
const UCharsetMatch *match;
const UCharsetMatch **matches;
int nmatches;
int ret;
// Confirm we have the profile of functions we need.
if (ucsdet_open == NULL ||
ucsdet_setText == NULL ||
ucsdet_detect == NULL ||
ucsdet_detectAll == NULL ||
ucsdet_getName == NULL ||
ucsdet_close == NULL) {
return FunctionNotAvailableError(interp);
}
bytes = (char *) Tcl_GetBytesFromObj(interp, objPtr, &len);
if (bytes == NULL) {
return TCL_ERROR;
}
UErrorCodex status = U_ZERO_ERRORZ;
UCharsetDetector* csd = ucsdet_open(&status);
if (U_FAILURE(status)) {
return IcuError(interp, "Could not open charset detector", status);
}
ucsdet_setText(csd, bytes, len, &status);
if (U_FAILURE(status)) {
IcuError(interp, "Could not set detection text", status);
ucsdet_close(csd);
return TCL_ERROR;
}
if (all) {
matches = ucsdet_detectAll(csd, &nmatches, &status);
} else {
match = ucsdet_detect(csd, &status);
matches = &match;
nmatches = match ? 1 : 0;
}
if (U_FAILURE(status) || nmatches == 0) {
ret = IcuError(interp, "Could not detect character set", status);
} else {
int i;
Tcl_Obj *resultObj = Tcl_NewListObj(nmatches, NULL);
for (i = 0; i < nmatches; ++i) {
const char *name = ucsdet_getName(matches[i], &status);
if (U_FAILURE(status) || name == NULL) {
name = "unknown";
status = U_ZERO_ERRORZ; /* Reset on failure */
}
Tcl_ListObjAppendElement(
NULL, resultObj, Tcl_NewStringObj(name, TCL_AUTO_LENGTH));
}
Tcl_SetObjResult(interp, resultObj);
ret = TCL_OK;
}
ucsdet_close(csd);
return ret;
}
static int
DetectableEncodings(
Tcl_Interp *interp)
{
// Confirm we have the profile of functions we need.
if (ucsdet_open == NULL ||
ucsdet_getAllDetectableCharsets == NULL ||
ucsdet_close == NULL ||
uenum_next == NULL ||
uenum_count == NULL ||
uenum_close == NULL) {
return FunctionNotAvailableError(interp);
}
UErrorCodex status = U_ZERO_ERRORZ;
UCharsetDetector *csd = ucsdet_open(&status);
if (U_FAILURE(status)) {
return IcuError(interp, "Could not open charset detector", status);
}
int ret;
UEnumeration *enumerator = ucsdet_getAllDetectableCharsets(csd, &status);
if (U_FAILURE(status) || enumerator == NULL) {
IcuError(interp, "Could not get list of detectable encodings", status);
ret = TCL_ERROR;
} else {
int32_t count = uenum_count(enumerator, &status);
if (U_FAILURE(status)) {
IcuError(interp, "Could not get charset enumerator count", status);
ret = TCL_ERROR;
} else {
int i;
Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL);
for (i = 0; i < count; ++i) {
const char *name;
int32_t len;
name = uenum_next(enumerator, &len, &status);
if (name == NULL || U_FAILURE(status)) {
name = "unknown";
len = 7;
status = U_ZERO_ERRORZ; /* Reset on error */
}
Tcl_ListObjAppendElement(
NULL, resultObj, Tcl_NewStringObj(name, len));
}
Tcl_SetObjResult(interp, resultObj);
ret = TCL_OK;
}
uenum_close(enumerator);
}
ucsdet_close(csd);
return ret;
}
/*
*------------------------------------------------------------------------
*
* IcuObjToUCharDString --
*
* Encodes a Tcl_Obj value in ICU UChars and stores in dsPtr.
*
* Results:
* Return TCL_OK / TCL_ERROR.
*
* Side effects:
* *dsPtr should be cleared by caller only if return code is TCL_OK.
*
*------------------------------------------------------------------------
*/
static int
IcuObjToUCharDString(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int strict,
Tcl_DString *dsPtr)
{
Tcl_Encoding encoding;
/*
* TODO - not the most efficient to get an encoding every time.
* However, we cannot use Tcl_UtfToChar16DString as that blithely
* ignores invalid or ill-formed UTF8 strings.
*/
encoding = Tcl_GetEncoding(interp, "utf-16");
if (encoding == NULL) {
return TCL_ERROR;
}
int result;
char *s;
Tcl_Size len;
s = Tcl_GetStringFromObj(objPtr, &len);
result = Tcl_UtfToExternalDStringEx(interp,
encoding,
s,
len,
strict ? TCL_ENCODING_PROFILE_STRICT
: TCL_ENCODING_PROFILE_REPLACE,
dsPtr,
NULL);
if (result != TCL_OK) {
Tcl_DStringFree(dsPtr); /* Must be done on error */
/* TCL_CONVER_* errors -> TCL_ERROR */
result = TCL_ERROR;
}
Tcl_FreeEncoding(encoding);
return result;
}
/*
*------------------------------------------------------------------------
*
* IcuObjFromUCharDString --
*
* Stores a Tcl_Obj value by decoding ICU UChars in dsPtr.
*
* Results:
* Return Tcl_Obj or NULL on error.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static Tcl_Obj *
IcuObjFromUCharDString(
Tcl_Interp *interp,
Tcl_DString *dsPtr,
int strict)
{
Tcl_Encoding encoding;
/*
* TODO - not the most efficient to get an encoding every time.
* However, we cannot use Tcl_UtfToChar16DString as that blithely
* ignores invalid or ill-formed UTF8 strings.
*/
encoding = Tcl_GetEncoding(interp, "utf-16");
if (encoding == NULL) {
return NULL;
}
Tcl_Obj *objPtr = NULL;
char *s = Tcl_DStringValue(dsPtr);
Tcl_Size len = Tcl_DStringLength(dsPtr);
Tcl_DString dsOut;
int result;
result = Tcl_ExternalToUtfDStringEx(interp,
encoding,
s,
len,
strict ? TCL_ENCODING_PROFILE_STRICT
: TCL_ENCODING_PROFILE_REPLACE,
&dsOut,
NULL);
if (result == TCL_OK) {
objPtr = Tcl_DStringToObj(&dsOut); /* Clears dsPtr! */
}
Tcl_FreeEncoding(encoding);
return objPtr;
}
/*
*------------------------------------------------------------------------
*
* EncodingDetectObjCmd --
*
* Implements the Tcl command EncodingDetect.
* encdetect - returns names of all detectable encodings
* encdetect BYTES ?-all? - return detected encoding(s)
*
* Results:
* TCL_OK - Success.
* TCL_ERROR - Error.
*
* Side effects:
* Interpreter result holds result or error message.
*
*------------------------------------------------------------------------
*/
static int
IcuDetectObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1 , objv, "?bytes ?-all??");
return TCL_ERROR;
}
if (objc == 1) {
return DetectableEncodings(interp);
}
int all = 0;
if (objc == 3) {
if (strcmp("-all", Tcl_GetString(objv[2]))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Invalid option %s, must be \"-all\"",
Tcl_GetString(objv[2])));
return TCL_ERROR;
}
all = 1;
}
return DetectEncoding(interp, objv[1], all);
}
/*
*------------------------------------------------------------------------
*
* IcuConverterNamesObjCmd --
*
* Sets interp result to list of available ICU converters.
*
* Results:
* TCL_OK - Success.
* TCL_ERROR - Error.
*
* Side effects:
* Interpreter result holds list of converter names.
*
*------------------------------------------------------------------------
*/
static int
IcuConverterNamesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1 , objv, "");
return TCL_ERROR;
}
if (ucnv_countAvailable == NULL || ucnv_getAvailableName == NULL) {
return FunctionNotAvailableError(interp);
}
int32_t count = ucnv_countAvailable();
if (count <= 0) {
return TCL_OK;
}
Tcl_Obj *resultObj = Tcl_NewListObj(count, NULL);
int32_t i;
for (i = 0; i < count; ++i) {
const char *name = ucnv_getAvailableName(i);
if (name) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(name, TCL_AUTO_LENGTH));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* IcuConverterAliasesObjCmd --
*
* Sets interp result to list of available ICU converters.
*
* Results:
* TCL_OK - Success.
* TCL_ERROR - Error.
*
* Side effects:
* Interpreter result holds list of converter names.
*
*------------------------------------------------------------------------
*/
static int
IcuConverterAliasesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1 , objv, "convertername");
return TCL_ERROR;
}
if (ucnv_countAliases == NULL || ucnv_getAlias == NULL) {
return FunctionNotAvailableError(interp);
}
const char *name = Tcl_GetString(objv[1]);
UErrorCodex status = U_ZERO_ERRORZ;
uint16_t count = ucnv_countAliases(name, &status);
if (status != U_AMBIGUOUS_ALIAS_WARNING && U_FAILURE(status)) {
return IcuError(interp, "Could not get aliases", status);
}
if (count <= 0) {
return TCL_OK;
}
Tcl_Obj *resultObj = Tcl_NewListObj(count, NULL);
uint16_t i;
for (i = 0; i < count; ++i) {
status = U_ZERO_ERRORZ; /* Reset in case U_AMBIGUOUS_ALIAS_WARNING */
const char *aliasName = ucnv_getAlias(name, i, &status);
if (status != U_AMBIGUOUS_ALIAS_WARNING && U_FAILURE(status)) {
status = U_ZERO_ERRORZ; /* Reset error for next iteration */
continue;
}
if (aliasName) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(aliasName, TCL_AUTO_LENGTH));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* IcuConverttoDString --
*
* Converts a string in ICU default encoding to the specified encoding.
*
* Results:
* TCL_OK / TCL_ERROR
*
* Side effects:
* On success, encoded string is stored in output dsOutPtr
*
*------------------------------------------------------------------------
*/
static int
IcuConverttoDString(
Tcl_Interp *interp,
Tcl_DString *dsInPtr, /* Input UTF16 */
const char *icuEncName,
int strict,
Tcl_DString *dsOutPtr) /* Output encoded string. */
{
if (ucnv_open == NULL || ucnv_close == NULL ||
ucnv_fromUChars == NULL || UCNV_FROM_U_CALLBACK_STOP == NULL) {
return FunctionNotAvailableError(interp);
}
UErrorCodex status = U_ZERO_ERRORZ;
UConverter *ucnvPtr = ucnv_open(icuEncName, &status);
if (ucnvPtr == NULL) {
return IcuError(interp, "Could not get encoding converter", status);
}
if (strict) {
ucnv_setFromUCallBack(ucnvPtr, UCNV_FROM_U_CALLBACK_STOP, NULL, NULL, NULL, &status);
if (U_FAILURE(status)) {
/* TODO - use ucnv_getInvalidUChars to retrieve failing chars */
ucnv_close(ucnvPtr);
return IcuError(interp, "Could not set conversion callback", status);
}
}
UCharx *utf16 = (UCharx *) Tcl_DStringValue(dsInPtr);
Tcl_Size utf16len = Tcl_DStringLength(dsInPtr) / sizeof(UCharx);
Tcl_Size dstLen, dstCapacity;
if (utf16len > INT_MAX) {
Tcl_SetObjResult( interp,
Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE));
return TCL_ERROR;
}
dstCapacity = utf16len;
Tcl_DStringInit(dsOutPtr);
Tcl_DStringSetLength(dsOutPtr, dstCapacity);
dstLen = ucnv_fromUChars(ucnvPtr, Tcl_DStringValue(dsOutPtr), dstCapacity,
utf16, utf16len, &status);
if (U_FAILURE(status)) {
switch (status) {
case U_STRING_NOT_TERMINATED_WARNING:
break; /* We don't care */
case U_BUFFER_OVERFLOW_ERROR:
Tcl_DStringSetLength(dsOutPtr, dstLen);
status = U_ZERO_ERRORZ; /* Reset before call */
dstLen = ucnv_fromUChars(ucnvPtr, Tcl_DStringValue(dsOutPtr), dstLen,
utf16, utf16len, &status);
if (U_SUCCESS(status)) {
break;
}
/* FALLTHRU */
default:
Tcl_DStringFree(dsOutPtr);
ucnv_close(ucnvPtr);
return IcuError(interp, "ICU error while encoding", status);
}
}
Tcl_DStringSetLength(dsOutPtr, dstLen);
ucnv_close(ucnvPtr);
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* IcuBytesToUCharDString --
*
* Converts encoded bytes to ICU UChars in a Tcl_DString
*
* Results:
* TCL_OK / TCL_ERROR
*
* Side effects:
* On success, encoded string is stored in output dsOutPtr
*
*------------------------------------------------------------------------
*/
static int
IcuBytesToUCharDString(
Tcl_Interp *interp,
const unsigned char *bytes,
Tcl_Size nbytes,
const char *icuEncName,
int strict,
Tcl_DString *dsOutPtr) /* Output UChar string. */
{
if (ucnv_open == NULL || ucnv_close == NULL ||
ucnv_toUChars == NULL || UCNV_TO_U_CALLBACK_STOP == NULL) {
return FunctionNotAvailableError(interp);
}
if (nbytes > INT_MAX) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE));
return TCL_ERROR;
}
UErrorCodex status = U_ZERO_ERRORZ;
UConverter *ucnvPtr = ucnv_open(icuEncName, &status);
if (ucnvPtr == NULL) {
return IcuError(interp, "Could not get encoding converter", status);
}
if (strict) {
ucnv_setToUCallBack(ucnvPtr, UCNV_TO_U_CALLBACK_STOP, NULL, NULL, NULL, &status);
if (U_FAILURE(status)) {
/* TODO - use ucnv_getInvalidUChars to retrieve failing chars */
ucnv_close(ucnvPtr);
return IcuError(interp, "Could not set conversion callback", status);
}
}
int dstLen;
int dstCapacity = (int) nbytes; /* In UChar's */
Tcl_DStringInit(dsOutPtr);
Tcl_DStringSetLength(dsOutPtr, dstCapacity);
dstLen = ucnv_toUChars(ucnvPtr, (UCharx *)Tcl_DStringValue(dsOutPtr), dstCapacity,
(const char *)bytes, nbytes, &status);
if (U_FAILURE(status)) {
switch (status) {
case U_STRING_NOT_TERMINATED_WARNING:
break; /* We don't care */
case U_BUFFER_OVERFLOW_ERROR:
dstCapacity = sizeof(UCharx) * dstLen;
Tcl_DStringSetLength(dsOutPtr, dstCapacity);
status = U_ZERO_ERRORZ; /* Reset before call */
dstLen = ucnv_toUChars(ucnvPtr, (UCharx *)Tcl_DStringValue(dsOutPtr), dstCapacity,
(const char *)bytes, nbytes, &status);
if (U_SUCCESS(status)) {
break;
}
/* FALLTHRU */
default:
Tcl_DStringFree(dsOutPtr);
ucnv_close(ucnvPtr);
return IcuError(interp, "ICU error while decoding", status);
}
}
Tcl_DStringSetLength(dsOutPtr, sizeof(UCharx)*dstLen);
ucnv_close(ucnvPtr);
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* IcuNormalizeUCharDString --
*
* Normalizes the UTF-16 encoded data
*
* Results:
* TCL_OK / TCL_ERROR
*
* Side effects:
* Normalized data is stored in dsOutPtr which should only be
* Tcl_DStringFree-ed if return code is TCL_OK.
*
*------------------------------------------------------------------------
*/
static int
IcuNormalizeUCharDString(
Tcl_Interp *interp,
Tcl_DString *dsInPtr, /* Input UTF16 */
NormalizationMode mode,
Tcl_DString *dsOutPtr) /* Output normalized UTF16. */
{
typedef UNormalizer2 *(*normFn)(UErrorCodex *);
normFn fn = NULL;
switch (mode) {
case MODE_NFC:
fn = unorm2_getNFCInstance;
break;
case MODE_NFD:
fn = unorm2_getNFDInstance;
break;
case MODE_NFKC:
fn = unorm2_getNFKCInstance;
break;
case MODE_NFKD:
fn = unorm2_getNFKDInstance;
break;
}
if (fn == NULL || unorm2_normalize == NULL) {
return FunctionNotAvailableError(interp);
}
UErrorCodex status = U_ZERO_ERRORZ;
UNormalizer2 *normalizer = fn(&status);
if (U_FAILURE(status)) {
return IcuError(interp, "Could not get ICU normalizer", status);
}
UCharx *utf16;
Tcl_Size utf16len;
UCharx *normPtr;
int32_t normLen;
utf16 = (UCharx *) Tcl_DStringValue(dsInPtr);
utf16len = Tcl_DStringLength(dsInPtr) / sizeof(UCharx);
if (utf16len > INT_MAX) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE));
return TCL_ERROR;
}
Tcl_DStringInit(dsOutPtr);
Tcl_DStringSetLength(dsOutPtr, utf16len * sizeof(UCharx));
normPtr = (UCharx *) Tcl_DStringValue(dsOutPtr);
normLen = unorm2_normalize(
normalizer, utf16, utf16len, normPtr, utf16len, &status);
if (U_FAILURE(status)) {
switch (status) {
case U_STRING_NOT_TERMINATED_WARNING:
/* No problem, don't need it terminated */
break;
case U_BUFFER_OVERFLOW_ERROR:
/* Expand buffer */
Tcl_DStringSetLength(dsOutPtr, normLen * sizeof(UCharx));
normPtr = (UCharx *) Tcl_DStringValue(dsOutPtr);
status = U_ZERO_ERRORZ; /* Need to clear error! */
normLen = unorm2_normalize(
normalizer, utf16, utf16len, normPtr, normLen, &status);
if (U_SUCCESS(status)) {
break;
}
/* FALLTHRU */
default:
Tcl_DStringFree(dsOutPtr);
return IcuError(interp, "String normalization failed", status);
}
}
Tcl_DStringSetLength(dsOutPtr, normLen * sizeof(UCharx));
return TCL_OK;
}
/*
* Common function for parsing convert options.
*/
static int IcuParseConvertOptions(
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[],
int *strictPtr,
Tcl_Obj **failindexVarPtr)
{
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-profile PROFILE? ICUENCNAME STRING");
return TCL_ERROR;
}
objc -= 2; /* truncate fixed arguments */
/* Use GetIndexFromObj for option parsing so -failindex can be added later */
static const char *optNames[] = {"-profile", "-failindex", NULL};
enum { OPT_PROFILE, OPT_FAILINDEX } opt;
int i;
int strict = 1;
for (i = 1; i < objc; ++i) {
if (Tcl_GetIndexFromObj(
interp, objv[i], optNames, "option", 0, &opt) != TCL_OK) {
return TCL_ERROR;
}
++i;
if (i == objc) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Missing value for option %s.",
Tcl_GetString(objv[i - 1])));
return TCL_ERROR;
}
const char *s = Tcl_GetString(objv[i]);
switch (opt) {
case OPT_PROFILE:
if (!strcmp(s, "replace")) {
strict = 0;
} else if (strcmp(s, "strict")) {
Tcl_SetObjResult(
interp,
Tcl_ObjPrintf("Invalid value \"%s\" supplied for option"
" \"-profile\". Must be \"strict\" or \"replace\".",
s));
return TCL_ERROR;
}
break;
case OPT_FAILINDEX:
/* TBD */
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Option -failindex not implemented.", TCL_INDEX_NONE));
return TCL_ERROR;
}
}
*strictPtr = strict;
*failindexVarPtr = NULL;
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* IcuConvertfromObjCmd --
*
* Implements the Tcl command "icu convertfrom"
* icu convertfrom ?-profile replace|strict? encoding string
*
* Results:
* TCL_OK - Success.
* TCL_ERROR - Error.
*
* Side effects:
* Interpreter result holds result or error message.
*
*------------------------------------------------------------------------
*/
static int
IcuConvertfromObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int strict;
Tcl_Obj *failindexVar;
if (IcuParseConvertOptions(interp, objc, objv, &strict, &failindexVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_Size nbytes;
const unsigned char *bytes = Tcl_GetBytesFromObj(interp, objv[objc-1], &nbytes);
if (bytes == NULL) {
return TCL_ERROR;
}
Tcl_DString ds;
if (IcuBytesToUCharDString(interp, bytes, nbytes,
Tcl_GetString(objv[objc-2]), strict, &ds) != TCL_OK) {
return TCL_ERROR;
}
Tcl_Obj *resultObj = IcuObjFromUCharDString(interp, &ds, strict);
if (resultObj) {
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
} else {
return TCL_ERROR;
}
}
/*
*------------------------------------------------------------------------
*
* IcuConverttoObjCmd --
*
* Implements the Tcl command "icu convertto"
* icu convertto ?-profile replace|strict? encoding string
*
* Results:
* TCL_OK - Success.
* TCL_ERROR - Error.
*
* Side effects:
* Interpreter result holds result or error message.
*
*------------------------------------------------------------------------
*/
static int
IcuConverttoObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int strict;
Tcl_Obj *failindexVar;
if (IcuParseConvertOptions(interp, objc, objv, &strict, &failindexVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DString dsIn;
Tcl_DString dsOut;
if (IcuObjToUCharDString(interp, objv[objc - 1], strict, &dsIn) != TCL_OK ||
IcuConverttoDString(interp, &dsIn,
Tcl_GetString(objv[objc-2]), strict, &dsOut) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
Tcl_NewByteArrayObj((unsigned char *)Tcl_DStringValue(&dsOut),
Tcl_DStringLength(&dsOut)));
Tcl_DStringFree(&dsOut);
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* IcuNormalizeObjCmd --
*
* Implements the Tcl command "icu normalize"
* icu normalize ?-profile replace|strict? ?-mode nfc|nfd|nfkc|nfkd? string
*
* Results:
* TCL_OK - Success.
* TCL_ERROR - Error.
*
* Side effects:
* Interpreter result holds result or error message.
*
*------------------------------------------------------------------------
*/
static int
IcuNormalizeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *optNames[] = {"-profile", "-mode", NULL};
enum { OPT_PROFILE, OPT_MODE } opt;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-profile PROFILE? ?-mode MODE? STRING");
return TCL_ERROR;
}
int i;
int strict = 1;
NormalizationMode mode = MODE_NFC;
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(
interp, objv[i], optNames, "option", 0, &opt) != TCL_OK) {
return TCL_ERROR;
}
++i;
if (i == (objc-1)) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Missing value for option %s.",
Tcl_GetString(objv[i - 1])));
return TCL_ERROR;
}
const char *s = Tcl_GetString(objv[i]);
switch (opt) {
case OPT_PROFILE:
if (!strcmp(s, "replace")) {
strict = 0;
} else if (strcmp(s, "strict")) {
Tcl_SetObjResult(
interp,
Tcl_ObjPrintf("Invalid value \"%s\" supplied for option \"-profile\". Must be "
"\"strict\" or \"replace\".",
s));
return TCL_ERROR;
}
break;
case OPT_MODE:
if (Tcl_GetIndexFromObj(interp, objv[i], normalizationForms, "normalization mode", 0, &mode) != TCL_OK) {
return TCL_ERROR;
}
break;
}
}
Tcl_DString dsIn;
Tcl_DString dsNorm;
if (IcuObjToUCharDString(interp, objv[objc - 1], strict, &dsIn) != TCL_OK ||
IcuNormalizeUCharDString(interp, &dsIn, mode, &dsNorm) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringFree(&dsIn);
Tcl_Obj *objPtr = IcuObjFromUCharDString(interp, &dsNorm, strict);
Tcl_DStringFree(&dsNorm);
if (objPtr) {
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
else {
return TCL_ERROR;
}
}
/*
*------------------------------------------------------------------------
*
* TclIcuCleanup --
*
* Called whenever a command referencing the ICU function table is
* deleted. When the reference count drops to zero, the table is released
* and the ICU shared libraries are unloaded.
*
*------------------------------------------------------------------------
*/
static void
TclIcuCleanup(
TCL_UNUSED(void *))
{
Tcl_MutexLock(&icu_mutex);
if (icu_fns.nopen-- <= 1) {
int i;
if (u_cleanup != NULL) {
u_cleanup();
}
for (i = 0; i < (int)(sizeof(icu_fns.libs) / sizeof(icu_fns.libs[0]));
++i) {
if (icu_fns.libs[i] != NULL) {
Tcl_FSUnloadFile(NULL, icu_fns.libs[i]);
}
}
memset(&icu_fns, 0, sizeof(icu_fns));
}
Tcl_MutexUnlock(&icu_mutex);
}
/*
*------------------------------------------------------------------------
*
* IcuFindSymbol --
*
* Finds an ICU symbol in a shared library and returns its value.
*
* Caller must be holding icu_mutex lock.
*
* Results:
* Returns the symbol value or NULL if not found.
*
*------------------------------------------------------------------------
*/
static void *
IcuFindSymbol(
Tcl_LoadHandle loadH, /* Handle to shared library containing symbol */
const char *name, /* Name of function */
const char *suffix /* Suffix that may be present */
)
{
/*
* ICU symbols may have a version suffix depending on how it was built.
* Rather than try both forms every time, suffixConvention remembers if a
* suffix is needed (all functions will have it, or none will)
* 0 - don't know, 1 - have suffix, -1 - no suffix
*/
static int suffixConvention = 0;
char symbol[256];
void *value = NULL;
/* Note we only update suffixConvention on a positive result */
strcpy(symbol, name);
if (suffixConvention <= 0) {
/* Either don't need suffix or don't know if we do */
value = Tcl_FindSymbol(NULL, loadH, symbol);
if (value) {
suffixConvention = -1; /* Remember that no suffixes present */
return value;
}
}
if (suffixConvention >= 0) {
/* Either need suffix or don't know if we do */
strcat(symbol, suffix);
value = Tcl_FindSymbol(NULL, loadH, symbol);
if (value) {
suffixConvention = 1;
}
}
return value;
}
/*
*------------------------------------------------------------------------
*
* TclIcuInit --
*
* Load the ICU commands into the given interpreter. If the ICU
* commands have never previously been loaded, the ICU libraries are
* loaded first.
*
*------------------------------------------------------------------------
*/
static void
TclIcuInit(
Tcl_Interp *interp)
{
Tcl_MutexLock(&icu_mutex);
char icuversion[4] = "_80"; /* Highest ICU version + 1 */
/*
* The initialization below clones the one from Tk. May need revisiting.
* ICU shared library names as well as function names *may* be versioned.
* See https://unicode-org.github.io/icu/userguide/icu4c/packaging.html
* for the gory details.
*/
if (icu_fns.nopen == 0) {
int i = 0;
Tcl_Obj *nameobj;
static const char *iculibs[] = {
#if defined(_WIN32)
# define DLLNAME "icu%s%s.dll"
"icuuc??.dll", /* Windows, user-provided */
NULL,
"cygicuuc??.dll", /* When running under Cygwin */
#elif defined(__CYGWIN__)
# define DLLNAME "cygicu%s%s.dll"
"cygicuuc??.dll",
#elif defined(MAC_OSX_TCL)
# define DLLNAME "libicu%s.%s.dylib"
"libicuuc.??.dylib",
#else
# define DLLNAME "libicu%s.so.%s"
"libicuuc.so.??",
#endif
NULL
};
/* Going back down to ICU version 60 */
while ((icu_fns.libs[0] == NULL) && (icuversion[1] >= '6')) {
if (--icuversion[2] < '0') {
icuversion[1]--; icuversion[2] = '9';
}
#if defined(__CYGWIN__)
i = 2;
#else
i = 0;
#endif
while (iculibs[i] != NULL) {
Tcl_ResetResult(interp);
nameobj = Tcl_NewStringObj(iculibs[i], TCL_AUTO_LENGTH);
char *nameStr = Tcl_GetString(nameobj);
char *p = strchr(nameStr, '?');
if (p != NULL) {
memcpy(p, icuversion+1, 2);
}
Tcl_IncrRefCount(nameobj);
if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL,
&icu_fns.libs[0]) == TCL_OK) {
if (p == NULL) {
icuversion[0] = '\0';
}
Tcl_DecrRefCount(nameobj);
break;
}
Tcl_DecrRefCount(nameobj);
++i;
}
}
if (icu_fns.libs[0] != NULL) {
/* Loaded icuuc, load others with the same version */
nameobj = Tcl_ObjPrintf(DLLNAME, "i18n", icuversion+1);
Tcl_IncrRefCount(nameobj);
/* Ignore errors. Calls to contained functions will fail. */
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
Tcl_DecrRefCount(nameobj);
}
#ifdef _WIN32
/*
* On Windows, if no ICU install found, look for the system's
* (Win10 1703 or later). There are two cases. Newer systems
* have icu.dll containing all functions. Older systems have
* icucc.dll and icuin.dll
*/
if (icu_fns.libs[0] == NULL) {
Tcl_ResetResult(interp);
nameobj = Tcl_NewStringObj("icu.dll", TCL_AUTO_LENGTH);
Tcl_IncrRefCount(nameobj);
if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[0])
== TCL_OK) {
/* Reload same for second set of functions. */
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL,
&icu_fns.libs[1]);
/* Functions do NOT have version suffixes */
icuversion[0] = '\0';
}
Tcl_DecrRefCount(nameobj);
}
if (icu_fns.libs[0] == NULL) {
/* No icu.dll. Try last fallback */
Tcl_ResetResult(interp);
nameobj = Tcl_NewStringObj("icuuc.dll", TCL_AUTO_LENGTH);
Tcl_IncrRefCount(nameobj);
if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[0])
== TCL_OK) {
Tcl_DecrRefCount(nameobj);
nameobj = Tcl_NewStringObj("icuin.dll", TCL_AUTO_LENGTH);
Tcl_IncrRefCount(nameobj);
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL,
&icu_fns.libs[1]);
/* Functions do NOT have version suffixes */
icuversion[0] = '\0';
}
Tcl_DecrRefCount(nameobj);
}
#endif // _WIN32
/* Symbol may have version (Windows, FreeBSD), or not (Linux) */
#define ICUUC_SYM(name) \
do { \
icu_fns._##name = \
(fn_##name)IcuFindSymbol(icu_fns.libs[0], #name, icuversion); \
} while (0)
if (icu_fns.libs[0] != NULL) {
ICUUC_SYM(u_cleanup);
ICUUC_SYM(u_errorName);
ICUUC_SYM(u_strFromUTF32);
ICUUC_SYM(u_strFromUTF32WithSub);
ICUUC_SYM(u_strToUTF32);
ICUUC_SYM(u_strToUTF32WithSub);
ICUUC_SYM(ucnv_close);
ICUUC_SYM(ucnv_countAliases);
ICUUC_SYM(ucnv_countAvailable);
ICUUC_SYM(ucnv_fromUChars);
ICUUC_SYM(ucnv_getAlias);
ICUUC_SYM(ucnv_getAvailableName);
ICUUC_SYM(ucnv_open);
ICUUC_SYM(ucnv_setFromUCallBack);
ICUUC_SYM(ucnv_setToUCallBack);
ICUUC_SYM(ucnv_toUChars);
ICUUC_SYM(UCNV_FROM_U_CALLBACK_STOP);
ICUUC_SYM(UCNV_TO_U_CALLBACK_STOP);
ICUUC_SYM(ubrk_open);
ICUUC_SYM(ubrk_close);
ICUUC_SYM(ubrk_preceding);
ICUUC_SYM(ubrk_following);
ICUUC_SYM(ubrk_previous);
ICUUC_SYM(ubrk_next);
ICUUC_SYM(ubrk_setText);
ICUUC_SYM(uenum_close);
ICUUC_SYM(uenum_count);
ICUUC_SYM(uenum_next);
ICUUC_SYM(unorm2_getNFCInstance);
ICUUC_SYM(unorm2_getNFDInstance);
ICUUC_SYM(unorm2_getNFKCInstance);
ICUUC_SYM(unorm2_getNFKDInstance);
ICUUC_SYM(unorm2_normalize);
#undef ICUUC_SYM
}
#define ICUIN_SYM(name) \
do { \
icu_fns._##name = \
(fn_##name)IcuFindSymbol(icu_fns.libs[1], #name, icuversion); \
} while (0)
if (icu_fns.libs[1] != NULL) {
ICUIN_SYM(ucsdet_close);
ICUIN_SYM(ucsdet_detect);
ICUIN_SYM(ucsdet_detectAll);
ICUIN_SYM(ucsdet_getName);
ICUIN_SYM(ucsdet_getAllDetectableCharsets);
ICUIN_SYM(ucsdet_open);
ICUIN_SYM(ucsdet_setText);
#undef ICUIN_SYM
}
}
if (icu_fns.libs[0] != NULL) {
/*
* Note refcounts updated BEFORE command definition to protect
* against self redefinition.
*/
if (icu_fns.libs[1] != NULL) {
/* Commands needing both libraries */
/* Ref count number of commands */
icu_fns.nopen += 3;
Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::convertto",
IcuConverttoObjCmd, 0, TclIcuCleanup);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::convertfrom",
IcuConvertfromObjCmd, 0, TclIcuCleanup);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::detect",
IcuDetectObjCmd, 0, TclIcuCleanup);
}
/* Commands needing only libs[0] (icuuc) */
/* Ref count number of commands */
icu_fns.nopen += 3; /* UPDATE AS CMDS ADDED/DELETED BELOW */
Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::converters",
IcuConverterNamesObjCmd, 0, TclIcuCleanup);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::aliases",
IcuConverterAliasesObjCmd, 0, TclIcuCleanup);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::normalize",
IcuNormalizeObjCmd, 0, TclIcuCleanup);
}
Tcl_MutexUnlock(&icu_mutex);
}
/*
*------------------------------------------------------------------------
*
* TclLoadIcuObjCmd --
*
* Loads and initializes ICU
*
* Results:
* TCL_OK - Success.
* TCL_ERROR - Error.
*
* Side effects:
* Interpreter result holds result or error message.
*
*------------------------------------------------------------------------
*/
int
TclLoadIcuObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1 , objv, "");
return TCL_ERROR;
}
TclIcuInit(interp);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* coding: utf-8
* End:
*/
|
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
const char **tablePtr;
/*
* Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
* of the code there. This is a bit inefficient but simpler.
*/
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
const char **tablePtr;
/*
* Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
* of the code there. This is a bit inefficient but simpler.
*/
result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
/*
* Build a string table from the list.
*/
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
const Tcl_ObjInternalRep *irPtr;
if (offset < (Tcl_Size)sizeof(char *)) {
if (interp) {
| | | | | | | | | | | | | | | | 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 |
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
const Tcl_ObjInternalRep *irPtr;
if (offset < (Tcl_Size)sizeof(char *)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Invalid %s value %" TCL_SIZE_MODIFIER "d.",
"struct offset", offset));
}
return TCL_ERROR;
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if ((indexRep->tablePtr == tablePtr)
&& (indexRep->offset == offset)
&& (indexRep->index != TCL_INDEX_NONE)) {
index = indexRep->index;
goto uncachedDone;
}
}
}
/*
* Lookup the value of the object in the table. Accept unique
* abbreviations unless TCL_EXACT is set in flags.
*/
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (char *)NULL);
return TCL_ERROR;
}
i++;
| | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (char *)NULL);
return TCL_ERROR;
}
i++;
result = TclListObjLength(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
if ((errorLength % 2) != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error options must have an even number of elements",
-1));
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
objPtr = objv[objc - 1];
/*
* Check that table is a valid list first, since we want to handle that
* error case regardless of level.
*/
| | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
objPtr = objv[objc - 1];
/*
* Check that table is a valid list first, since we want to handle that
* error case regardless of level.
*/
result = TclListObjLength(interp, tablePtr, &i);
if (result != TCL_OK) {
return result;
}
result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags,
&i);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
Tcl_Obj **tableObjv, *resultPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
| | | | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 |
Tcl_Obj **tableObjv, *resultPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
string = TclGetStringFromObj(objv[2], &length);
for (t = 0; t < tableObjc; t++) {
elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* A prefix cannot match if it is longest.
*/
if (length <= elemLength) {
if (TclpUtfNcmp2(elemString, string, length) == 0) {
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 |
Tcl_Obj **tableObjv;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
| | | | | 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 |
Tcl_Obj **tableObjv;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
string = TclGetStringFromObj(objv[2], &length);
resultString = NULL;
resultLength = 0;
for (t = 0; t < tableObjc; t++) {
elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* First check if the prefix string matches the element. A prefix
* cannot match if it is longest.
*/
if ((length > elemLength) ||
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
Tcl_AppendToObj(objPtr, " or \"", TCL_INDEX_NONE);
} else {
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", TCL_INDEX_NONE);
}
/*
| | | 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 |
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
Tcl_AppendToObj(objPtr, " or \"", TCL_INDEX_NONE);
} else {
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", TCL_INDEX_NONE);
}
/*
* If processing an ensemble implementation, rewrite the results in
* terms of how the ensemble was invoked.
*/
if (iPtr->ensembleRewrite.sourceObjs != NULL) {
Tcl_Size toSkip = iPtr->ensembleRewrite.numInsertedObjs;
Tcl_Size toPrint = iPtr->ensembleRewrite.numRemovedObjs;
Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp);
|
| ︙ | ︙ | |||
868 869 870 871 872 873 874 |
if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
| | | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 |
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *)NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
| | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 |
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *)NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
elementStr = TclGetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
|
| ︙ | ︙ | |||
1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 |
Tcl_Size srcIndex; /* Location from which to read next argument
* from objv. */
Tcl_Size dstIndex; /* Used to keep track of current arguments
* being processed, primarily for error
* reporting. */
Tcl_Size objc; /* # arguments in objv still to process. */
Tcl_Size length; /* Number of characters in current argument */
if (remObjv != NULL) {
/*
* Then we should copy the name of the command (0th argument). The
* upper bound on the number of elements is known, and (undocumented,
* but historically true) there should be a NULL argument after the
* last result. [Bug 3413857]
| > | 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 |
Tcl_Size srcIndex; /* Location from which to read next argument
* from objv. */
Tcl_Size dstIndex; /* Used to keep track of current arguments
* being processed, primarily for error
* reporting. */
Tcl_Size objc; /* # arguments in objv still to process. */
Tcl_Size length; /* Number of characters in current argument */
Tcl_Size gf_ret; /* Return value from Tcl_ArgvGenFuncProc*/
if (remObjv != NULL) {
/*
* Then we should copy the name of the command (0th argument). The
* upper bound on the number of elements is known, and (undocumented,
* but historically true) there should be a NULL argument after the
* last result. [Bug 3413857]
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 |
srcIndex = dstIndex = 1;
objc = *objcPtr-1;
while (objc > 0) {
curArg = objv[srcIndex];
srcIndex++;
objc--;
| | | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
srcIndex = dstIndex = 1;
objc = *objcPtr-1;
while (objc > 0) {
curArg = objv[srcIndex];
srcIndex++;
objc--;
str = TclGetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
c = 0;
}
/*
|
| ︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "too many (%" TCL_SIZE_MODIFIER "d) arguments for TCL_ARGV_GENFUNC", objc)); goto error; } Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr; | | | > > > | 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"too many (%" TCL_SIZE_MODIFIER "d) arguments for TCL_ARGV_GENFUNC", objc));
goto error;
}
Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
infoPtr->srcPtr;
gf_ret = handlerProc(infoPtr->clientData, interp, objc,
&objv[srcIndex], infoPtr->dstPtr);
if (gf_ret < 0) {
goto error;
} else {
srcIndex += gf_ret;
objc -= gf_ret;
}
break;
}
case TCL_ARGV_HELP:
PrintUsage(interp, argTable);
goto error;
default:
|
| ︙ | ︙ |
Changes to generic/tclInt.decls.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 |
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst)
}
| < < < < < | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst)
}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {
Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv,
Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
}
declare 10 {
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr,
const char **simpleNamePtr)
}
declare 39 {
Tcl_ObjCmdProc *TclGetObjInterpProc(void)
}
declare 40 {
| | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr,
const char **simpleNamePtr)
}
declare 39 {
Tcl_ObjCmdProc *TclGetObjInterpProc(void)
}
declare 40 {
int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *modeFlagsPtr)
}
declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
const char *procName)
}
declare 93 {
void TclProcDeleteProc(void *clientData)
}
declare 96 {
int TclRenameCommand(Tcl_Interp *interp, const char *oldName,
| | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
const char *procName)
}
declare 93 {
void TclProcDeleteProc(void *clientData)
}
declare 96 {
int TclRenameCommand(Tcl_Interp *interp, const char *oldName,
const char *newName)
}
declare 97 {
void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
}
declare 98 {
int TclServiceIdle(void)
}
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
declare 129 {
int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
declare 130 {
int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name)
}
declare 131 {
void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 138 {
const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
# This is used by TclX, but should otherwise be considered private
declare 141 {
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 |
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
| < < < < < < < < | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
void TclChannelEventScriptInvoker(void *clientData, int flags)
}
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Size index, Tcl_Obj *valuePtr)
}
| < < < < < < < | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Size index, Tcl_Obj *valuePtr)
}
# 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,
|
| ︙ | ︙ | |||
467 468 469 470 471 472 473 |
declare 176 {
void TclCleanupVar(Var *varPtr, Var *arrayPtr)
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
| < < < < < < < < < < < < < < < < | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
declare 176 {
void TclCleanupVar(Var *varPtr, Var *arrayPtr)
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
}
# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 {
int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive,
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 |
void *TclStackAlloc(Tcl_Interp *interp, TCL_HASH_TYPE numBytes)
}
declare 216 {
void TclStackFree(Tcl_Interp *interp, void *freePtr)
}
declare 217 {
int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr,
| | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
void *TclStackAlloc(Tcl_Interp *interp, TCL_HASH_TYPE numBytes)
}
declare 216 {
void TclStackFree(Tcl_Interp *interp, void *freePtr)
}
declare 217 {
int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr,
Tcl_Namespace *namespacePtr, int isProcCallFrame)
}
declare 218 {
void TclPopStackFrame(Tcl_Interp *interp)
}
# TIP 431: temporary directory creation function
declare 219 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
Tcl_Size keyc, Tcl_Obj *const keyv[], int flags)
}
declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
declare 227 {
void TclSetNsPath(Namespace *nsPtr, Tcl_Size pathLength,
| | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
Tcl_Size keyc, Tcl_Obj *const keyv[], int flags)
}
declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
declare 227 {
void TclSetNsPath(Namespace *nsPtr, Tcl_Size pathLength,
Tcl_Namespace *pathAry[])
}
declare 229 {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
const char *myName, int myFlags, int index)
}
declare 230 {
Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
declare 233 {
void TclGetSrcInfoForPc(CmdFrame *contextPtr)
}
# Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :(
declare 234 {
Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
| | < < < < | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
declare 233 {
void TclGetSrcInfoForPc(CmdFrame *contextPtr)
}
# Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :(
declare 234 {
Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
int *newPtr)
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
# TIP #285: Script cancellation support.
declare 237 {
int TclResetCancellation(Tcl_Interp *interp, int force)
}
# NRE functions for "rogue" extensions to exploit NRE; they will need to
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | # only available on the designated platform. interface tclIntPlat ################################ # Platform specific functions | < < < < | 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
# only available on the designated platform.
interface tclIntPlat
################################
# Platform specific functions
declare 1 {
int TclpCloseFile(TclFile file)
}
declare 2 {
Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr)
}
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | #include <stdio.h> #include <ctype.h> #include <stdarg.h> #include <stdlib.h> #include <stdint.h> | < < < < | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | #include <stdio.h> #include <ctype.h> #include <stdarg.h> #include <stdlib.h> #include <stdint.h> #include <string.h> #include <locale.h> /* * Ensure WORDS_BIGENDIAN is defined correctly: * Needs to happen here in addition to configure to work with fat compiles on * Darwin (where configure runs only once for multiple architectures). */ |
| ︙ | ︙ | |||
216 217 218 219 220 221 222 |
* Special hashtable for variables: This is just a Tcl_HashTable with nsPtr
* and arrayPtr fields added at the end so that variables can find their
* namespace and possibly containing array without having to copy a pointer in
* their struct by accessing them via their hPtr->tablePtr.
*/
typedef struct TclVarHashTable {
| | | | > | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
* Special hashtable for variables: This is just a Tcl_HashTable with nsPtr
* and arrayPtr fields added at the end so that variables can find their
* namespace and possibly containing array without having to copy a pointer in
* their struct by accessing them via their hPtr->tablePtr.
*/
typedef struct TclVarHashTable {
Tcl_HashTable table; /* "Inherit" from Tcl_HashTable. */
struct Namespace *nsPtr; /* The namespace containing the variables. */
#if TCL_MAJOR_VERSION > 8
struct Var *arrayPtr; /* The array containing the variables, if they
* are variables in an array at all. */
#endif /* TCL_MAJOR_VERSION > 8 */
} TclVarHashTable;
/*
* This is for itcl - it likes to search our varTables directly :(
*/
|
| ︙ | ︙ | |||
253 254 255 256 257 258 259 |
typedef struct Namespace {
char *name; /* The namespace's simple (unqualified) name.
* This contains no ::'s. The name of the
* global namespace is "" although "::" is an
* synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
| | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
typedef struct Namespace {
char *name; /* The namespace's simple (unqualified) name.
* This contains no ::'s. The name of the
* global namespace is "" although "::" is an
* synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
void *clientData; /* An arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure invoked when deleting the
* namespace to, e.g., free clientData. */
struct Namespace *parentPtr;/* Points to the namespace that contains this
* one. NULL if this is the global
* namespace. */
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
* NULL, there are no children. */
#endif
#if TCL_MAJOR_VERSION > 8
size_t nsId; /* Unique id for the namespace. */
#else
unsigned long nsId;
#endif
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
* NULL, there are no children. */
#endif
#if TCL_MAJOR_VERSION > 8
size_t nsId; /* Unique id for the namespace. */
#else
unsigned long nsId;
#endif
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
* flags NS_DYING and NS_DEAD listed below. */
Tcl_Size activationCount; /* Number of "activations" or active call
* frames for this namespace that are on the
* Tcl call stack. The namespace won't be
* freed until activationCount becomes zero. */
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
* commands; however, no namespace qualifiers
* are allowed. NULL if no export patterns are
* registered. */
Tcl_Size numExportPatterns; /* Number of export patterns currently
* registered using "namespace export". */
Tcl_Size maxExportPatterns; /* Number of export patterns for which space
* is currently allocated. */
| | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
* commands; however, no namespace qualifiers
* are allowed. NULL if no export patterns are
* registered. */
Tcl_Size numExportPatterns; /* Number of export patterns currently
* registered using "namespace export". */
Tcl_Size maxExportPatterns; /* Number of export patterns for which space
* is currently allocated. */
Tcl_Size cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this namespace
* has already cached a Command* pointer; this
* causes all its cached Command* pointers to
* be invalidated. */
Tcl_Size resolverEpoch; /* Incremented whenever (a) the name
* resolution rules change for this namespace
* or (b) a newly added command shadows a
* command that is compiled to bytecodes. This
* invalidates all byte codes compiled in the
* namespace, causing the code to be
* recompiled under the new rules.*/
Tcl_ResolveCmdProc *cmdResProc;
|
| ︙ | ︙ | |||
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 |
/*
* Flags passed to TclGetNamespaceForQualName:
*
* TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns.
* TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns.
* TCL_CREATE_NS_IF_UNKNOWN - Create unknown namespaces.
* TCL_FIND_ONLY_NS - The name sought is a namespace name.
*/
#define TCL_CREATE_NS_IF_UNKNOWN 0x800
#define TCL_FIND_ONLY_NS 0x1000
/*
* The client data for an ensemble command. This consists of the table of
* commands that are actually exported by the namespace, and an epoch counter
* that, combined with the exportLookupEpoch field of the namespace structure,
* defines whether the table contains valid data or will need to be recomputed
* next time the ensemble command is called.
*/
typedef struct EnsembleConfig {
Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
| > > > | | 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 |
/*
* Flags passed to TclGetNamespaceForQualName:
*
* TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns.
* TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns.
* TCL_CREATE_NS_IF_UNKNOWN - Create unknown namespaces.
* TCL_FIND_ONLY_NS - The name sought is a namespace name.
* TCL_FIND_IF_NOT_SIMPLE - Retrieve last namespace even if the rest of
* name is not simple name (contains ::).
*/
#define TCL_CREATE_NS_IF_UNKNOWN 0x800
#define TCL_FIND_ONLY_NS 0x1000
#define TCL_FIND_IF_NOT_SIMPLE 0x2000
/*
* The client data for an ensemble command. This consists of the table of
* commands that are actually exported by the namespace, and an epoch counter
* that, combined with the exportLookupEpoch field of the namespace structure,
* defines whether the table contains valid data or will need to be recomputed
* next time the ensemble command is called.
*/
typedef struct EnsembleConfig {
Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
Tcl_Size epoch; /* The epoch at which this ensemble's table of
* exported commands is valid. */
char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
* consistent points, this will have the same
* number of entries as there are entries in
* the subcommandTable hash. */
Tcl_HashTable subcommandTable;
/* Hash table of ensemble subcommand names,
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
* results passed directly back to the caller
* (including the error code) unless the code
* is TCL_CONTINUE in which case the
* subcommand will be re-parsed by the ensemble
* core, presumably because the ensemble
* itself has been updated. */
Tcl_Obj *parameterList; /* List of ensemble parameter names. */
| | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 |
* results passed directly back to the caller
* (including the error code) unless the code
* is TCL_CONTINUE in which case the
* subcommand will be re-parsed by the ensemble
* core, presumably because the ensemble
* itself has been updated. */
Tcl_Obj *parameterList; /* List of ensemble parameter names. */
Tcl_Size numParameters; /* Cached number of parameters. This is either
* 0 (if the parameterList field is NULL) or
* the length of the list in the parameterList
* field. */
} EnsembleConfig;
/*
* Various bits for the EnsembleConfig.flags field.
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
* specific C procedure whenever certain operations are performed on a
* variable.
*/
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
* flags are performed on variable. */
| | | | 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 |
* specific C procedure whenever certain operations are performed on a
* variable.
*/
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
* flags are performed on variable. */
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
struct VarTrace *nextPtr; /* Next in list of traces associated with a
* particular variable. */
} VarTrace;
/*
* The following structure defines a command trace, which is used to invoke a
* specific C procedure whenever certain operations are performed on a
* command.
*/
typedef struct CommandTrace {
Tcl_CommandTraceProc *traceProc;
/* Procedure to call when operations given by
* flags are performed on command. */
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr;
/* Next in list of traces associated with a
* particular command. */
Tcl_Size refCount; /* Used to ensure this structure is not
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
* to in a procedure, or a variable created by
* "upvar", this field points to the
* referenced variable's Var struct. */
} value;
} Var;
typedef struct VarInHash {
| | | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
* to in a procedure, or a variable created by
* "upvar", this field points to the
* referenced variable's Var struct. */
} value;
} Var;
typedef struct VarInHash {
Var var; /* "Inherit" from Var. */
Tcl_Size refCount; /* Counts number of active uses of this
* variable: 1 for the entry in the hash
* table, 1 for each additional variable whose
* linkPtr points here, 1 for each nested
* trace active on variable, and 1 if the
* variable is a namespace variable. This
* record can't be deleted until refCount
|
| ︙ | ︙ | |||
827 828 829 830 831 832 833 |
* MODULE_SCOPE int TclIsVarTemporary(Var *varPtr);
* MODULE_SCOPE int TclIsVarArgument(Var *varPtr);
* MODULE_SCOPE int TclIsVarResolved(Var *varPtr);
*/
#define TclVarFindHiddenArray(varPtr,arrayPtr) \
do { \
| | | | | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
* MODULE_SCOPE int TclIsVarTemporary(Var *varPtr);
* MODULE_SCOPE int TclIsVarArgument(Var *varPtr);
* MODULE_SCOPE int TclIsVarResolved(Var *varPtr);
*/
#define TclVarFindHiddenArray(varPtr,arrayPtr) \
do { \
if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \
(TclVarParentArray(varPtr) != NULL)) { \
arrayPtr = TclVarParentArray(varPtr); \
} \
} while(0)
#define TclIsVarScalar(varPtr) \
!((varPtr)->flags & (VAR_ARRAY|VAR_LINK))
#define TclIsVarLink(varPtr) \
((varPtr)->flags & VAR_LINK)
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
/*
* Macros for direct variable access by TEBC.
*/
#define TclIsVarTricky(varPtr,trickyFlags) \
( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \
| | | | | | | 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 |
/*
* Macros for direct variable access by TEBC.
*/
#define TclIsVarTricky(varPtr,trickyFlags) \
( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \
|| (TclIsVarInHash(varPtr) \
&& (TclVarParentArray(varPtr) != NULL) \
&& (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) \
(TclIsVarDirectWritable(varPtr) &&\
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
*/
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
| | | | | 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 |
*/
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
Tcl_Size nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
Tcl_Size frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
#if TCL_MAJOR_VERSION < 9
int flags;
#endif
Tcl_Obj *defValuePtr; /* Pointer to the default value of an
* argument, if any. NULL if not an argument
* or, if an argument, no default value. */
Tcl_ResolvedVarInfo *resolveInfo;
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
* is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
#if TCL_MAJOR_VERSION > 8
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
* although only VAR_ARGUMENT, VAR_TEMPORARY,
* and VAR_RESOLVED make sense. */
#endif
char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If
* the name is NULL, this will just be '\0'.
* The actual size of this field will be large
* enough to hold the name. MUST BE THE LAST
* FIELD IN THE STRUCTURE! */
} CompiledLocal;
/*
|
| ︙ | ︙ | |||
1051 1052 1053 1054 1055 1056 1057 |
Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
#if TCL_MAJOR_VERSION > 8
Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */
#else
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
#endif
| | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
#if TCL_MAJOR_VERSION > 8
Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */
#else
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
#endif
void *clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details. */
Tcl_CmdObjTraceDeleteProc *delProc;
/* Procedure to call when trace is deleted. */
} Trace;
|
| ︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 | } ActiveInterpTrace; /* * Flag values designating types of execution traces. See tclTrace.c for * related flag values. * * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces. | | | < | | < | > > > > > > > > | > > | > < | | 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 |
} ActiveInterpTrace;
/*
* Flag values designating types of execution traces. See tclTrace.c for
* related flag values.
*
* TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces.
* - passed to Tcl_CreateObjTrace to set up
* "enterstep" traces.
* TCL_TRACE_LEAVE_EXEC - triggers leave/leavestep traces.
* - passed to Tcl_CreateObjTrace to set up
* "leavestep" traces.
*/
#define TCL_TRACE_ENTER_EXEC 1
#define TCL_TRACE_LEAVE_EXEC 2
#if TCL_MAJOR_VERSION > 8
#define TclObjTypeHasProc(objPtr, proc) (((objPtr)->typePtr \
&& ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \
|| (offsetof(Tcl_ObjType, proc) < (objPtr)->typePtr->version))) ? \
((objPtr)->typePtr)->proc : NULL)
MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *);
/*
* Abstract List
*
* This structure provides the functions used in List operations to emulate a
* List for AbstractList types.
*/
static inline Tcl_Size
TclObjTypeLength(
Tcl_Obj *objPtr)
{
Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc);
return proc(objPtr);
}
static inline int
TclObjTypeIndex(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size index,
Tcl_Obj **elemObjPtr)
{
Tcl_ObjTypeIndexProc *proc = TclObjTypeHasProc(objPtr, indexProc);
return proc(interp, objPtr, index, elemObjPtr);
}
static inline int
TclObjTypeSlice(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size fromIdx,
Tcl_Size toIdx,
Tcl_Obj **newObjPtr)
{
Tcl_ObjTypeSliceProc *proc = TclObjTypeHasProc(objPtr, sliceProc);
return proc(interp, objPtr, fromIdx, toIdx, newObjPtr);
}
static inline int
TclObjTypeReverse(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Obj **newObjPtr)
{
Tcl_ObjTypeReverseProc *proc = TclObjTypeHasProc(objPtr, reverseProc);
return proc(interp, objPtr, newObjPtr);
}
static inline int
TclObjTypeGetElements(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size *objCPtr,
Tcl_Obj ***objVPtr)
{
Tcl_ObjTypeGetElements *proc = TclObjTypeHasProc(objPtr, getElementsProc);
return proc(interp, objPtr, objCPtr, objVPtr);
}
static inline Tcl_Obj*
TclObjTypeSetElement(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size indexCount,
Tcl_Obj *const indexArray[],
Tcl_Obj *valueObj)
{
Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(objPtr, setElementProc);
return proc(interp, objPtr, indexCount, indexArray, valueObj);
}
static inline int
TclObjTypeReplace(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size first,
Tcl_Size numToDelete,
Tcl_Size numToInsert,
Tcl_Obj *const insertObjs[])
{
Tcl_ObjTypeReplaceProc *proc = TclObjTypeHasProc(objPtr, replaceProc);
return proc(interp, objPtr, first, numToDelete, numToInsert, insertObjs);
}
static inline int
TclObjTypeInOperator(
Tcl_Interp *interp,
Tcl_Obj *valueObj,
Tcl_Obj *listObj,
int *boolResult)
{
Tcl_ObjTypeInOperatorProc *proc = TclObjTypeHasProc(listObj, inOperProc);
return proc(interp, valueObj, listObj, boolResult);
}
#endif /* TCL_MAJOR_VERSION > 8 */
/*
* The structure below defines an entry in the assocData hash table which is
* associated with an interpreter. The entry contains a pointer to a function
* to call when the interpreter is deleted, and a pointer to a user-defined
* piece of data.
*/
typedef struct AssocData {
Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
void *clientData; /* Value to pass to proc. */
} AssocData;
/*
* The structure below defines a call frame. A call frame defines a naming
* context for a procedure call: its local naming scope (for local variables)
* and its global naming scope (a namespace, perhaps the global :: namespace).
* A call frame can also define the naming context for a namespace eval or
|
| ︙ | ︙ | |||
1222 1223 1224 1225 1226 1227 1228 |
/*
* Will be grown to contain: pointers to the varnames (allocated at the end),
* plus the init values for each variable (suitable to be memcopied on init)
*/
typedef struct LocalCache {
| | | | | | < | | | > | | | | | 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 |
/*
* Will be grown to contain: pointers to the varnames (allocated at the end),
* plus the init values for each variable (suitable to be memcopied on init)
*/
typedef struct LocalCache {
Tcl_Size refCount; /* Reference count. */
Tcl_Size numVars; /* Number of variables. */
Tcl_Obj *varName0; /* First variable name. */
} LocalCache;
#define localName(framePtr, i) \
((&((framePtr)->localCachePtr->varName0))[(i)])
MODULE_SCOPE void TclFreeLocalCache(Tcl_Interp *interp,
LocalCache *localCachePtr);
typedef struct CallFrame {
Namespace *nsPtr; /* Points to the namespace used to resolve
* commands and global variables. */
int isProcCallFrame; /* If 0, the frame was pushed to execute a
* namespace command and var references are
* treated as references to namespace vars;
* varTablePtr and compiledLocals are ignored.
* If FRAME_IS_PROC is set, the frame was
* pushed to execute a Tcl procedure and may
* have local vars. */
Tcl_Size objc; /* This and objv below describe the arguments
* for this procedure call. */
Tcl_Obj *const *objv; /* Array of argument objects. */
struct CallFrame *callerPtr;/* Value of interp->framePtr when this
* procedure was invoked (i.e. next higher in
* stack of all active procedures). */
struct CallFrame *callerVarPtr;
/* Value of interp->varFramePtr when this
* procedure was invoked (i.e. determines
* variable scoping within caller). Same as
* callerPtr unless an "uplevel" command or
* something equivalent was active in the
* caller). */
Tcl_Size level; /* Level of this procedure, for "uplevel"
* purposes (i.e. corresponds to nesting of
* callerVarPtr's, not callerPtr's). 1 for
* outermost procedure, 0 for top-level. */
Proc *procPtr; /* Points to the structure defining the called
* procedure. Used to get information such as
* the number of compiled local variables
* (local variables assigned entries ["slots"]
* in the compiledLocals array below). */
TclVarHashTable *varTablePtr;
/* Hash table containing local variables not
* recognized by the compiler, or created at
* execution time through, e.g., upvar.
* Initially NULL and created if needed. */
Tcl_Size numCompiledLocals; /* Count of local variables recognized
* by the compiler including arguments. */
Var *compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
void *clientData; /* Pointer to some context that is used by
* object systems. The meaning of the contents
* of this field is defined by the code that
* sets it, and it should only ever be set by
* the code that is pushing the frame. In that
* case, the code that sets it should also
* have some means of discovering what the
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr; /* Pointer to the start of the cached variable
* names and initialisation data for local
* variables. */
Tcl_Obj *tailcallPtr; /* NULL if no tailcall is scheduled */
} CallFrame;
#define FRAME_IS_PROC 0x1 /* Frame is a procedure body. */
#define FRAME_IS_LAMBDA 0x2 /* Frame is a lambda term body. */
#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's
* clientData field contains a CallContext
* reference. Part of TIP#257. */
#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of
* the [oo::define] command; the clientData
* field contains an Object reference that has
* been confirmed to refer to a class. Part of
|
| ︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 |
* General data. Always available.
*/
int type; /* Values see below. */
int level; /* Number of frames in stack, prevent O(n)
* scan of list. */
Tcl_Size *line; /* Lines the words of the command start on. */
| | | 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 |
* General data. Always available.
*/
int type; /* Values see below. */
int level; /* Number of frames in stack, prevent O(n)
* scan of list. */
Tcl_Size *line; /* Lines the words of the command start on. */
Tcl_Size nline; /* Number of lines in CmdFrame.line. */
CallFrame *framePtr; /* Procedure activation record, may be
* NULL. */
struct CmdFrame *nextPtr; /* Link to calling frame. */
/*
* Data needed for Eval vs TEBC
*
* EXECUTION CONTEXTS and usage of CmdFrame
|
| ︙ | ︙ | |||
1377 1378 1379 1380 1381 1382 1383 |
struct {
const void *codePtr;/* Byte code currently executed... */
const char *pc; /* ... and instruction pointer. */
} tebc;
} data;
Tcl_Obj *cmdObj;
const char *cmd; /* The executed command, if possible... */
| | | | | | 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 |
struct {
const void *codePtr;/* Byte code currently executed... */
const char *pc; /* ... and instruction pointer. */
} tebc;
} data;
Tcl_Obj *cmdObj;
const char *cmd; /* The executed command, if possible... */
Tcl_Size len; /* ... and its length. */
const struct CFWordBC *litarg;
/* Link to set of literal arguments which have
* ben pushed on the lineLABCPtr stack by
* TclArgumentBCEnter(). These will be removed
* by TclArgumentBCRelease. */
} CmdFrame;
typedef struct CFWord {
CmdFrame *framePtr; /* CmdFrame to access. */
Tcl_Size word; /* Index of the word in the command. */
Tcl_Size refCount; /* Number of times the word is on the
* stack. */
} CFWord;
typedef struct CFWordBC {
CmdFrame *framePtr; /* CmdFrame to access. */
Tcl_Size pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
Tcl_Size word; /* Index of word in
* ExtCmdLoc.loc[cmd]->line[.] */
struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */
struct CFWordBC *nextPtr; /* Next entry for same command call. See
* CmdFrame litarg field for the list start. */
Tcl_Obj *obj; /* Back reference to hash table key */
} CFWordBC;
|
| ︙ | ︙ | |||
1425 1426 1427 1428 1429 1430 1431 |
* released by the function TclFreeObj(), in the file "tclObj.c", and also by
* the function TclThreadFinalizeObjects(), in the same file.
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
| | | 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 |
* released by the function TclFreeObj(), in the file "tclObj.c", and also by
* the function TclThreadFinalizeObjects(), in the same file.
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
Tcl_Size num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
Tcl_Size loc[TCLFLEXARRAY];/* Table of locations, as character offsets.
* The table is allocated as part of the
* structure, extending behind the nominal end
* of the structure. An entry containing the
* value -1 is put after the last location, as
* end-marker/sentinel. */
|
| ︙ | ︙ | |||
1468 1469 1470 1471 1472 1473 1474 |
* procedures (e.g. a lambda) so that their details can be reported correctly
* by [info frame]. Contains a sub-structure for each extra field.
*/
typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData);
typedef struct {
const char *name; /* Name of this field. */
| | | | | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 |
* procedures (e.g. a lambda) so that their details can be reported correctly
* by [info frame]. Contains a sub-structure for each extra field.
*/
typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData);
typedef struct {
const char *name; /* Name of this field. */
GetFrameInfoValueProc *proc;/* Function to generate a Tcl_Obj* from the
* clientData, or just use the clientData
* directly (after casting) if NULL. */
void *clientData; /* Context for above function, or Tcl_Obj* if
* proc field is NULL. */
} ExtraFrameInfoField;
typedef struct {
Tcl_Size length; /* Length of array. */
ExtraFrameInfoField fields[2];
/* Really as long as necessary, but this is
* long enough for nearly anything. */
} ExtraFrameInfo;
/*
*----------------------------------------------------------------
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 | /* * The type of procedures called by the Tcl bytecode compiler to compile * commands. Pointers to these procedures are kept in the Command structure * describing each command. The integer value returned by a CompileProc must * be one of the following: * * TCL_OK Compilation completed normally. | | | | | | | | | | | > > > | | | | | > > > > > > > > > > > > > < < < < < < < | | | | > | | | > | | < | > | > > | 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 |
/*
* The type of procedures called by the Tcl bytecode compiler to compile
* commands. Pointers to these procedures are kept in the Command structure
* describing each command. The integer value returned by a CompileProc must
* be one of the following:
*
* TCL_OK Compilation completed normally.
* TCL_ERROR Compilation could not be completed. This can be just a
* judgment by the CompileProc that the command is too
* complex to compile effectively, or it can indicate
* that in the current state of the interp, the command
* would raise an error. The bytecode compiler will not
* do any error reporting at compiler time. Error
* reporting is deferred until the actual runtime,
* because by then changes in the interp state may allow
* the command to be successfully evaluated.
*/
typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
struct Command *cmdPtr, struct CompileEnv *compEnvPtr);
/*
* The type of procedure called from the compilation hook point in
* SetByteCodeFromAny.
*/
typedef int (CompileHookProc)(Tcl_Interp *interp,
struct CompileEnv *compEnvPtr, void *clientData);
/*
* The data structure for a (linked list of) execution stacks. Note that the
* first word on a particular execution stack is NULL, which is used as a
* marker to say "go to the previous stack in the list" when unwinding the
* stack.
*/
typedef struct ExecStack {
struct ExecStack *prevPtr; /* Previous stack in list. */
struct ExecStack *nextPtr; /* Next stack in list. */
Tcl_Obj **markerPtr; /* The location of the NULL marker. */
Tcl_Obj **endPtr; /* Where the stack end is. */
Tcl_Obj **tosPtr; /* Where the stack top is. */
Tcl_Obj *stackWords[TCLFLEXARRAY];
/* The actual stack space, following this
* structure in memory. */
} ExecStack;
/*
* Saved copies of the stack frame references from the interpreter. Have to be
* restored into the interpreter to be used.
*/
typedef struct CorContext {
CallFrame *framePtr; /* See Interp.framePtr */
CallFrame *varFramePtr; /* See Interp.varFramePtr */
CmdFrame *cmdFramePtr; /* See Interp.cmdFramePtr */
Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
} CorContext;
/*
* The data structure defining the execution environment for ByteCode's.
* There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
* stack that holds command operands and results. The stack grows towards
* increasing addresses. The member stackPtr points to the stackItems of the
* currently active execution stack.
*/
typedef struct CoroutineData {
struct Command *cmdPtr; /* The command handle for the coroutine. */
struct ExecEnv *eePtr; /* The special execution environment (stacks,
* etc.) for the coroutine. */
struct ExecEnv *callerEEPtr;/* The execution environment for the caller of
* the coroutine, which might be the
* interpreter global environment or another
* coroutine. */
CorContext caller; /* Caller's saved execution context. */
CorContext running; /* This coroutine's saved execution context. */
Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
void *stackLevel; /* C stack frame reference. Used to try to
* ensure we don't overflow that stack. */
Tcl_Size auxNumLevels; /* While the coroutine is running the
* numLevels of the create/resume command is
* stored here; for suspended coroutines it
* holds the nesting numLevels at yield. */
Tcl_Size nargs; /* Number of args required for resuming this
* coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL
* means "0 or 1" (default),
* COROUTINE_ARGUMENTS_ARBITRARY means "any" */
Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in
* order to reset splice point in
* TclNRCoroutineActivateCallback if the
* coroutine is busy. */
} CoroutineData;
typedef struct ExecEnv {
ExecStack *execStackPtr; /* Points to the first item in the evaluation
* stack on the heap. */
Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */
struct Tcl_Interp *interp; /* Owning interpreter. */
struct NRE_callback *callbackPtr;
/* Top callback in NRE's stack. */
struct CoroutineData *corPtr;
/* Current coroutine. */
int rewind; /* Set when exception trapping is disabled
* because a context is being deleted (e.g.,
* the current coroutine has been deleted). */
} ExecEnv;
#define COR_IS_SUSPENDED(corPtr) \
((corPtr)->stackLevel == NULL)
/*
* The definitions for the LiteralTable and LiteralEntry structures. Each
|
| ︙ | ︙ | |||
1670 1671 1672 1673 1674 1675 1676 |
typedef struct LiteralTable {
LiteralEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables to avoid
* mallocs and frees. */
| | | | | | > | | 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 |
typedef struct LiteralTable {
LiteralEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables to avoid
* mallocs and frees. */
TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at
* **buckets. */
TCL_HASH_TYPE numEntries; /* Total number of entries present in
* table. */
TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
TCL_HASH_TYPE mask; /* Mask value used in hashing function. */
} LiteralTable;
/*
* The following structure defines for each Tcl interpreter various
* statistics-related information about the bytecode compiler and
* interpreter's operation in that interpreter.
*/
#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
size_t numExecutions; /* Number of ByteCodes executed. */
size_t numCompilations; /* Number of ByteCodes created. */
size_t numByteCodesFreed; /* Number of ByteCodes destroyed. */
size_t instructionCount[256];
/* Number of times each instruction was
* executed. */
double totalSrcBytes; /* Total source bytes ever compiled. */
double totalByteCodeBytes; /* Total bytes for all ByteCodes. */
double currentSrcBytes; /* Src bytes for all current ByteCodes. */
double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */
size_t srcCount[32]; /* Source size distribution: # of srcs of
* size [2**(n-1)..2**n), n in [0..32). */
size_t byteCodeCount[32]; /* ByteCode size distribution. */
size_t lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
double currentInstBytes; /* Instruction bytes-current ByteCodes. */
double currentLitBytes; /* Current literal bytes. */
double currentExceptBytes; /* Current exception table bytes. */
|
| ︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 |
*/
typedef struct {
const char *name; /* The name of the subcommand. */
Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */
CompileProc *compileProc; /* The compiler for the subcommand. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
| | | 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 |
*/
typedef struct {
const char *name; /* The name of the subcommand. */
Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */
CompileProc *compileProc; /* The compiler for the subcommand. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
void *clientData; /* Any clientData to give the command. */
int unsafe; /* Whether this command is to be hidden by
* default in a safe interpreter. */
} EnsembleImplMap;
/*
*----------------------------------------------------------------
* Data structures related to commands.
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
void *objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
| | | | 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 |
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
void *objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
void *clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Procedure invoked when deleting command to,
* e.g., free all client data. */
void *deleteData; /* Arbitrary value passed to deleteProc. */
int flags; /* Miscellaneous bits of information about
* command. See below for definitions. */
ImportRef *importRefPtr; /* List of each imported Command created in
* another namespace when this command is
* imported. These imported commands redirect
* invocations back to this command. The list
* is used to remove all those imported
|
| ︙ | ︙ | |||
1850 1851 1852 1853 1854 1855 1856 | * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further * recursive deletes will not be traced. * (these last two flags are defined in tcl.h) */ | | | | | | | | < | 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 | * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further * recursive deletes will not be traced. * (these last two flags are defined in tcl.h) */ #define CMD_DYING 0x01 #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 #define CMD_REDEF_IN_PROGRESS 0x10 #define CMD_VIA_RESOLVER 0x20 #define CMD_DEAD 0x40 /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 | /* Pointer to the exported Tcl stub table. In * ancient pre-8.1 versions of Tcl this was a * pointer to the objResultPtr or a pointer to a * buckets array in a hash table. Deployed stubs * enabled extensions check for a NULL pointer value * and for a TCL_STUBS_MAGIC value to verify they * are not [load]ing into one of those pre-stubs | | < | > > | 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 |
/* Pointer to the exported Tcl stub table. In
* ancient pre-8.1 versions of Tcl this was a
* pointer to the objResultPtr or a pointer to a
* buckets array in a hash table. Deployed stubs
* enabled extensions check for a NULL pointer value
* and for a TCL_STUBS_MAGIC value to verify they
* are not [load]ing into one of those pre-stubs
* interps. */
TclHandle handle; /* Handle used to keep track of when this
* interp is deleted. */
Namespace *globalNsPtr; /* The interpreter's global namespace. */
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
#if TCL_MAJOR_VERSION > 8
void (*optimizer)(void *envPtr);
/* Reference to the bytecode optimizer, if one
* is set. */
#else
union {
void (*optimizer)(void *envPtr);
Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The
* unused space in interp was repurposed for
* pluggable bytecode optimizers. The core
* contains one optimizer, which can be
|
| ︙ | ︙ | |||
2047 2048 2049 2050 2051 2052 2053 |
int unused1; /* No longer used (was termOffset) */
#endif
LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
* objects holding literals of scripts
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
| | | < | 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 |
int unused1; /* No longer used (was termOffset) */
#endif
LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
* objects holding literals of scripts
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
Tcl_Size compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
* invalidate existing ByteCodes when, e.g., a
* command with a compile procedure is
* redefined. */
Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer
* to its Proc structure; otherwise, this is
* NULL. Set by ObjInterpProc in tclProc.c and
* used by tclCompile.c to process local
* variables appropriately. */
ResolverScheme *resolverPtr;/* Linked list of name resolution schemes
* added to this interpreter. Schemes are
* added and removed by calling
* Tcl_AddInterpResolvers and
* Tcl_RemoveInterpResolver respectively. */
Tcl_Obj *scriptFile; /* NULL means there is no nested source
* command active; otherwise this points to
* pathPtr of the file being sourced. */
|
| ︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 |
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
* interp, or NULL if no active traces. */
ActiveInterpTrace *activeInterpTracePtr;
/* First in list of active traces for interp,
* or NULL if no active traces. */
| | | | 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 |
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
* interp, or NULL if no active traces. */
ActiveInterpTrace *activeInterpTracePtr;
/* First in list of active traces for interp,
* or NULL if no active traces. */
Tcl_Size tracesForbiddingInline;
/* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation. */
/*
* Fields used to manage extensible return options (TIP 90).
*/
|
| ︙ | ︙ | |||
2124 2125 2126 2127 2128 2129 2130 | * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ | | | 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 | * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ Tcl_Size cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is * reached. */ int cmdGranularity; /* Mod factor used to determine how often to * evaluate the limit check. */ |
| ︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 |
struct {
Tcl_Obj *const *sourceObjs;
/* What arguments were actually input into the
* *root* ensemble command? (Nested ensembles
* don't rewrite this.) NULL if we're not
* processing an ensemble. */
| | | > | 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 |
struct {
Tcl_Obj *const *sourceObjs;
/* What arguments were actually input into the
* *root* ensemble command? (Nested ensembles
* don't rewrite this.) NULL if we're not
* processing an ensemble. */
Tcl_Size numRemovedObjs;/* How many arguments have been stripped off
* because of ensemble processing. */
Tcl_Size numInsertedObjs;
/* How many of the current arguments were
* inserted by an ensemble. */
} ensembleRewrite;
/*
* TIP #219: Global info for the I/O system.
*/
|
| ︙ | ︙ | |||
2201 2202 2203 2204 2205 2206 2207 |
* values are "struct CmdFrame*". */
Tcl_HashTable *lineBCPtr; /* This table remembers for each ByteCode
* object the location information for its
* body. It is keyed by the address of the
* Proc structure for a procedure. The values
* are "struct ExtCmdLoc*". (See
* tclCompile.h) */
| | | < | 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 |
* values are "struct CmdFrame*". */
Tcl_HashTable *lineBCPtr; /* This table remembers for each ByteCode
* object the location information for its
* body. It is keyed by the address of the
* Proc structure for a procedure. The values
* are "struct ExtCmdLoc*". (See
* tclCompile.h) */
Tcl_HashTable *lineLABCPtr; /* Tcl_Obj* (by exact pointer) -> CFWordBC* */
Tcl_HashTable *lineLAPtr; /* This table remembers for each argument of a
* command on the execution stack the index of
* the argument in the command, and the
* location data of the command. It is keyed
* by the address of the Tcl_Obj containing
* the argument. The values are "struct
* CFWord*" (See tclBasic.c). This allows
* commands like uplevel, eval, etc. to find
* location information for their arguments,
* if they are a proper literal argument to an
* invoking command. Alt view: An index to the
* CmdFrame stack keyed by command argument
* holders. */
ContLineLoc *scriptCLLocPtr;/* This table points to the location data for
* invisible continuation lines in the script,
* if any. This pointer is set by the function
* TclEvalObjEx() in file "tclBasic.c", and
* used by function ...() in the same file.
* It does for the eval/direct path of script
* execution what CompileEnv.clLoc does for
* the bytecode compiler. */
/*
* TIP #268. The currently active selection mode, i.e. the package require
* preferences.
*/
int packagePrefer; /* Current package selection mode. */
|
| ︙ | ︙ | |||
2252 2253 2254 2255 2256 2257 2258 |
* Note that these are the same for all interps in the same thread. They
* just have to be initialised for the thread's parent interp, children
* inherit the value.
*
* They are used by the macros defined below.
*/
| | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 |
* Note that these are the same for all interps in the same thread. They
* just have to be initialised for the thread's parent interp, children
* inherit the value.
*
* They are used by the macros defined below.
*/
AllocCache *allocCache; /* Allocator cache for stack frames. */
void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData
* structs for this interp's thread; see
* tclObj.c and tclThreadAlloc.c */
int *asyncReadyPtr; /* Pointer to the asyncReady indicator for
* this interp's thread; see tclAsync.c */
/*
* The pointer to the object system root ekeko. c.f. TIP #257.
|
| ︙ | ︙ | |||
2287 2288 2289 2290 2291 2292 2293 |
Tcl_Obj *asyncCancelMsg; /* Error message set by async cancel handler
* for the propagation of arbitrary Tcl
* errors. This information, if present
* (asyncCancelMsg not NULL), takes precedence
* over the default error messages returned by
* a script cancellation operation. */
| | | | | | 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 |
Tcl_Obj *asyncCancelMsg; /* Error message set by async cancel handler
* for the propagation of arbitrary Tcl
* errors. This information, if present
* (asyncCancelMsg not NULL), takes precedence
* over the default error messages returned by
* a script cancellation operation. */
/*
* TIP #348 IMPLEMENTATION - Substituted error stack
*/
Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */
Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */
Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */
Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */
Tcl_Obj *innerContext; /* cached list for fast reallocation */
int resetErrorStack; /* controls cleaning up of ::errorStack */
#ifdef TCL_COMPILE_STATS
/*
* Statistical information about the bytecode compiler and interpreter's
* operation. This should be the last field of Interp.
*/
|
| ︙ | ︙ | |||
2322 2323 2324 2325 2326 2327 2328 |
/*
* Macros for script cancellation support (TIP #285).
*/
#define TclCanceled(iPtr) \
(((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND))
| | | | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 |
/*
* Macros for script cancellation support (TIP #285).
*/
#define TclCanceled(iPtr) \
(((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND))
#define TclSetCancelFlags(iPtr, cancelFlags) \
(iPtr)->flags |= CANCELED; \
if ((cancelFlags) & TCL_CANCEL_UNWIND) { \
(iPtr)->flags |= TCL_CANCEL_UNWIND; \
}
#define TclUnsetCancelFlags(iPtr) \
(iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND))
/*
* Macros for splicing into and out of doubly linked lists. They assume
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 | * Tcl_Canceled and checking if TCL_ERROR is returned. * This is a one-shot flag that is reset immediately upon * being detected; however, if the TCL_CANCEL_UNWIND flag * is set Tcl_Canceled will continue to report that the * script in progress has been canceled thereby allowing * the evaluation stack for the interp to be fully * unwound. | < < < < | 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 | * Tcl_Canceled and checking if TCL_ERROR is returned. * This is a one-shot flag that is reset immediately upon * being detected; however, if the TCL_CANCEL_UNWIND flag * is set Tcl_Canceled will continue to report that the * script in progress has been canceled thereby allowing * the evaluation stack for the interp to be fully * unwound. */ #define DELETED 1 #define ERR_ALREADY_LOGGED 4 #define INTERP_DEBUG_FRAME 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 |
| ︙ | ︙ | |||
2491 2492 2493 2494 2495 2496 2497 | (((x) + (TCL_ALIGN_BYTES - 1)) & ~(TCL_ALIGN_BYTES - 1)) /* * A common panic alert when memory allocation fails. */ #define TclOOM(ptr, size) \ | > | | 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 |
(((x) + (TCL_ALIGN_BYTES - 1)) & ~(TCL_ALIGN_BYTES - 1))
/*
* A common panic alert when memory allocation fails.
*/
#define TclOOM(ptr, size) \
((size) && ((ptr) || (Tcl_Panic( \
"unable to alloc %" TCL_Z_MODIFIER "u bytes", (size_t)(size)), 1)))
/*
* The following enum values are used to specify the runtime platform setting
* of the tclPlatform variable.
*/
typedef enum {
|
| ︙ | ︙ | |||
2561 2562 2563 2564 2565 2566 2567 |
* define the content of the list. The ListSpan specifies the range of slots
* within the ListStore that hold elements for this list. The ListSpan is
* optional in which case the list includes all the "in-use" slots of the
* ListStore.
*
*/
typedef struct ListStore {
| | | | | | | > | | | | | | > | | | | | > | | > | | > | | | > | | | | | | | | > | | | > | < | > | | | | | | | | | | | | | | > | > | | | | | | | | | | | | | > | | | | | < | | | 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 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 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 |
* define the content of the list. The ListSpan specifies the range of slots
* within the ListStore that hold elements for this list. The ListSpan is
* optional in which case the list includes all the "in-use" slots of the
* ListStore.
*
*/
typedef struct ListStore {
Tcl_Size firstUsed; /* Index of first slot in use within slots[] */
Tcl_Size numUsed; /* Number of slots in use (starting firstUsed) */
Tcl_Size numAllocated; /* Total number of slots[] array slots. */
size_t refCount; /* Number of references to this instance. */
int flags; /* LISTSTORE_* flags */
Tcl_Obj *slots[TCLFLEXARRAY];
/* Variable size array. Grown as needed */
} ListStore;
#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this
* store have their string representation
* derived from the list representation */
/* Max number of elements that can be contained in a list */
#define LIST_MAX \
((Tcl_Size)(((size_t)TCL_SIZE_MAX - offsetof(ListStore, slots)) \
/ sizeof(Tcl_Obj *)))
/* Memory size needed for a ListStore to hold numSlots_ elements */
#define LIST_SIZE(numSlots_) \
((Tcl_Size)(offsetof(ListStore, slots) \
+ ((numSlots_) * sizeof(Tcl_Obj *))))
/*
* ListSpan --
* See comments above for ListStore
*/
typedef struct ListSpan {
Tcl_Size spanStart; /* Starting index of the span. */
Tcl_Size spanLength; /* Number of elements in the span. */
size_t refCount; /* Count of references to this span record. */
} ListSpan;
#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
#define LIST_SPAN_THRESHOLD 101
#endif
/*
* ListRep --
* See comments above for ListStore
*/
typedef struct ListRep {
ListStore *storePtr; /* element array shared amongst different
* lists */
ListSpan *spanPtr; /* If not NULL, the span holds the range of
* slots within *storePtr that contain this
* list elements. */
} ListRep;
/*
* Macros used to get access list internal representations.
*
* Naming conventions:
* ListRep* - expect a pointer to a valid ListRep
* ListObj* - expect a pointer to a Tcl_Obj whose internal type is known to
* be a list (tclListType). Will crash otherwise.
* TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not
* be tclListType. These will convert as needed and return error if
* conversion not possible.
*/
/* Returns the starting slot for this listRep in the contained ListStore */
#define ListRepStart(listRepPtr_) \
((listRepPtr_)->spanPtr \
? (listRepPtr_)->spanPtr->spanStart \
: (listRepPtr_)->storePtr->firstUsed)
/* Returns the number of elements in this listRep */
#define ListRepLength(listRepPtr_) \
((listRepPtr_)->spanPtr \
? (listRepPtr_)->spanPtr->spanLength \
: (listRepPtr_)->storePtr->numUsed)
/* Returns a pointer to the first slot containing this ListRep elements */
#define ListRepElementsBase(listRepPtr_) \
(&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)])
/* Stores the number of elements and base address of the element array */
#define ListRepElements(listRepPtr_, objc_, objv_) \
(((objv_) = ListRepElementsBase(listRepPtr_)), \
((objc_) = ListRepLength(listRepPtr_)))
/* Returns 1/0 whether the ListRep's ListStore is shared. */
#define ListRepIsShared(listRepPtr_) ((listRepPtr_)->storePtr->refCount > 1)
/* Returns a pointer to the ListStore component */
#define ListObjStorePtr(listObj_) \
((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1))
/* Returns a pointer to the ListSpan component */
#define ListObjSpanPtr(listObj_) \
((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2))
/* Returns the ListRep internal representaton in a Tcl_Obj */
#define ListObjGetRep(listObj_, listRepPtr_) \
do { \
(listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \
(listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_); \
} while (0)
/* Returns the length of the list */
#define ListObjLength(listObj_, len_) \
((len_) = ListObjSpanPtr(listObj_) \
? ListObjSpanPtr(listObj_)->spanLength \
: ListObjStorePtr(listObj_)->numUsed)
/* Returns the starting slot index of this list's elements in the ListStore */
#define ListObjStart(listObj_) \
(ListObjSpanPtr(listObj_) \
? ListObjSpanPtr(listObj_)->spanStart \
: ListObjStorePtr(listObj_)->firstUsed)
/* Stores the element count and base address of this list's elements */
#define ListObjGetElements(listObj_, objc_, objv_) \
(((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \
(ListObjLength(listObj_, (objc_))))
/*
* Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
* is shared. Note by intent this only checks for sharing of ListStore,
* not spans.
*/
#define ListObjRepIsShared(listObj_) \
(ListObjStorePtr(listObj_)->refCount > 1)
/*
* Certain commands like concat are optimized if an existing string
* representation of a list object is known to be in canonical format (i.e.
* generated from the list representation). There are three conditions when
* this will be the case:
* (1) No string representation exists which means it will obviously have
* to be generated from the list representation when needed
* (2) The ListStore flags is marked canonical. This is done at the time
* the string representation is generated from the list under certain
* conditions (see comments in UpdateStringOfList).
* (3) The list representation does not have a span component. This is
* because list Tcl_Obj's with spans are always created from existing lists
* and never from strings (see SetListFromAny) and thus their string
* representation will always be canonical.
*/
#define ListObjIsCanonical(listObj_) \
(((listObj_)->bytes == NULL) \
|| (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \
|| ListObjSpanPtr(listObj_) != NULL)
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count and base address of this list's elements in objcPtr_ and objvPtr_.
* Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be
* converted to a list.
*/
#define TclListObjGetElements(interp_, listObj_, objcPtr_, objvPtr_) \
((TclHasInternalRep((listObj_), &tclListType)) \
? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
TCL_OK) \
: Tcl_ListObjGetElements( \
(interp_), (listObj_), (objcPtr_), (objvPtr_)))
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the
* Tcl_Obj cannot be converted to a list.
*/
#define TclListObjLength(interp_, listObj_, lenPtr_) \
((TclHasInternalRep((listObj_), &tclListType)) \
? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
: Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
#define TclListObjIsCanonical(listObj_) \
((TclHasInternalRep((listObj_), &tclListType)) \
? ListObjIsCanonical((listObj_)) \
: 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
* TclNRLmapCmd and their compilations.
*/
#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
* Macros providing a faster path to booleans and integers:
* Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
* and Tcl_GetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
#if TCL_MAJOR_VERSION > 8
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
((TclHasInternalRep((objPtr), &tclIntType) \
|| TclHasInternalRep((objPtr), &tclBooleanType)) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#else
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
((TclHasInternalRep((objPtr), &tclIntType)) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: (TclHasInternalRep((objPtr), &tclBooleanType)) \
? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#endif
#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
((TclHasInternalRep((objPtr), &tclIntType)) \
? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#else
#define TclGetLongFromObj(interp, objPtr, longPtr) \
((TclHasInternalRep((objPtr), &tclIntType) \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#endif
#define TclGetIntFromObj(interp, objPtr, intPtr) \
((TclHasInternalRep((objPtr), &tclIntType) \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
(((TclHasInternalRep((objPtr), &tclIntType)) \
&& ((objPtr)->internalRep.wideValue >= 0) \
&& ((objPtr)->internalRep.wideValue <= endValue)) \
? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* Macro used to save a function call for common uses of
* Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* Tcl_WideInt *wideIntPtr);
*/
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
((TclHasInternalRep((objPtr), &tclIntType)) \
? (*(wideIntPtr) = ((objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
/*
* Flag values for TclTraceDictPath().
*
* DICT_PATH_READ indicates that all entries on the path must exist but no
* updates will be needed.
*
|
| ︙ | ︙ | |||
2836 2837 2838 2839 2840 2841 2842 | * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef void *(TclFSGetCwdProc2)(void *clientData); typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, | | > | 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 | * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef void *(TclFSGetCwdProc2)(void *clientData); typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); /* * The following types are used for getting and storing platform-specific file * attributes in tclFCmd.c and the various platform-versions of that file. * This is done to have as much common code as possible in the file attributes * code. For more information about the callbacks, see TclFileAttrsCmd in * tclFCmd.c. |
| ︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 | /* *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ | | > > | | > | | | | | | | < | > | | | | < > > | | | | | < | > | > > > > | > | | | | | | | | > | > > > | > > | > | > > > > > | > > > | > > > > > > | > > > > > < | | | | | > | 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 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 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 |
/*
*----------------------------------------------------------------
* Data structures for process-global values.
*----------------------------------------------------------------
*/
typedef void (TclInitProcessGlobalValueProc)(char **valuePtr,
TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr);
#ifdef _WIN32
/* On Windows, all Unicode (except surrogates) are valid. */
# define TCLFSENCODING tclUtf8Encoding
#else
/* On Non-Windows, use the system encoding for validation checks. */
# define TCLFSENCODING NULL
#endif
/*
* A ProcessGlobalValue struct exists for each internal value in Tcl that is
* to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
* the value, and the gobal value is kept as a counted string, with epoch and
* mutex control. Each ProcessGlobalValue struct should be a static variable in
* some file.
*/
typedef struct ProcessGlobalValue {
Tcl_Size epoch; /* Epoch counter to detect changes in the
* global value. */
TCL_HASH_TYPE numBytes; /* Length of the global string. */
char *value; /* The global string value. */
Tcl_Encoding encoding; /* system encoding when global string was
* initialized. */
TclInitProcessGlobalValueProc *proc;
/* A procedure to initialize the global string
* copy when a "get" request comes in before
* any "set" request has been received. */
Tcl_Mutex mutex; /* Enforce orderly access from multiple
* threads. */
Tcl_ThreadDataKey key; /* Key for per-thread data holding the
* (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;
/*
*----------------------------------------------------------------------
* Flags for TclParseNumber
*----------------------------------------------------------------------
*/
#define TCL_PARSE_DECIMAL_ONLY 1
/* Leading zero doesn't denote octal or
* hex. */
#define TCL_PARSE_OCTAL_ONLY 2
/* Parse octal even without prefix. */
#define TCL_PARSE_HEXADECIMAL_ONLY 4
/* Parse hexadecimal even without prefix. */
#define TCL_PARSE_INTEGER_ONLY 8
/* Disable floating point parsing. */
#define TCL_PARSE_SCAN_PREFIXES 16
/* Use [scan] rules dealing with 0?
* prefixes. */
#define TCL_PARSE_NO_WHITESPACE 32
/* Reject leading/trailing whitespace. */
#define TCL_PARSE_BINARY_ONLY 64
/* Parse binary even without prefix. */
#define TCL_PARSE_NO_UNDERSCORE 128
/* Reject underscore digit separator */
/*
*----------------------------------------------------------------------
* Internal convenience macros for manipulating encoding flags. See
* TCL_ENCODING_PROFILE_* in tcl.h
*----------------------------------------------------------------------
*/
#define ENCODING_PROFILE_MASK 0xFF000000
#define ENCODING_PROFILE_GET(flags_) \
((flags_) & ENCODING_PROFILE_MASK)
#define ENCODING_PROFILE_SET(flags_, profile_) \
do { \
(flags_) &= ~ENCODING_PROFILE_MASK; \
(flags_) |= ((profile_) & ENCODING_PROFILE_MASK); \
} while (0)
/*
*----------------------------------------------------------------------
* Common functions for calculating overallocation. Trivial but allows for
* experimenting with growth factors without having to change code in
* multiple places. See TclAttemptAllocElemsEx and similar for usage
* examples. Best to use those functions. Direct use of TclUpsizeAlloc /
* TclResizeAlloc is needed in special cases such as when total size of
* memory block is limited to less than TCL_SIZE_MAX.
*----------------------------------------------------------------------
*/
static inline Tcl_Size
TclUpsizeAlloc(
TCL_UNUSED(Tcl_Size), /* oldSize. For future experiments with
* some growth algorithms that use this
* information. */
Tcl_Size needed,
Tcl_Size limit)
{
/* assert (oldCapacity < needed <= limit) */
if (needed < (limit - needed/2)) {
return needed + needed / 2;
} else {
return limit;
}
}
static inline Tcl_Size
TclUpsizeRetry(
Tcl_Size needed,
Tcl_Size lastAttempt)
{
/* assert(needed < lastAttempt); */
if (needed < lastAttempt - 1) {
/* (needed+lastAttempt)/2 but that formula may overflow Tcl_Size */
return needed + (lastAttempt - needed) / 2;
} else {
return needed;
}
}
MODULE_SCOPE void * TclAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
Tcl_Size leadSize, Tcl_Size *capacityPtr);
MODULE_SCOPE void * TclReallocElemsEx(void *oldPtr, Tcl_Size elemCount,
Tcl_Size elemSize, Tcl_Size leadSize,
Tcl_Size *capacityPtr);
MODULE_SCOPE void * TclAttemptReallocElemsEx(void *oldPtr,
Tcl_Size elemCount, Tcl_Size elemSize,
Tcl_Size leadSize, Tcl_Size *capacityPtr);
/* Alloc elemCount elements of size elemSize with leadSize header
* returning actual capacity (in elements) in *capacityPtr. */
static inline void *
TclAttemptAllocElemsEx(
Tcl_Size elemCount,
Tcl_Size elemSize,
Tcl_Size leadSize,
Tcl_Size *capacityPtr)
{
return TclAttemptReallocElemsEx(
NULL, elemCount, elemSize, leadSize, capacityPtr);
}
/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *
TclAllocEx(
Tcl_Size numBytes,
Tcl_Size *capacityPtr)
{
return TclAllocElemsEx(numBytes, 1, 0, capacityPtr);
}
/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *
TclAttemptAllocEx(
Tcl_Size numBytes,
Tcl_Size *capacityPtr)
{
return TclAttemptAllocElemsEx(numBytes, 1, 0, capacityPtr);
}
/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *
TclReallocEx(
void *oldPtr,
Tcl_Size numBytes,
Tcl_Size *capacityPtr)
{
return TclReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
}
/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
static inline void *
TclAttemptReallocEx(
void *oldPtr,
Tcl_Size numBytes,
Tcl_Size *capacityPtr)
{
return TclAttemptReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
}
/*
*----------------------------------------------------------------
* Variables shared among Tcl modules but not used by the outside world.
*----------------------------------------------------------------
*/
MODULE_SCOPE char *tclNativeExecutableName;
MODULE_SCOPE int tclFindExecutableSearchDone;
MODULE_SCOPE char *tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
/*
* Declarations related to internal encoding functions.
*/
MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
MODULE_SCOPE Tcl_Encoding tclUtf8Encoding;
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;
MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr;
MODULE_SCOPE void *tclTimeClientData;
/*
* Variables denoting the Tcl object types defined in the core.
*/
MODULE_SCOPE const Tcl_ObjType tclBignumType;
MODULE_SCOPE const Tcl_ObjType tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;
MODULE_SCOPE const Tcl_ObjType tclExprCodeType;
MODULE_SCOPE const Tcl_ObjType tclIntType;
MODULE_SCOPE const Tcl_ObjType tclIndexType;
MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
|
| ︙ | ︙ | |||
3152 3153 3154 3155 3156 3157 3158 | MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; | | > | | | | | | | < < | | < < | | | | | > | 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 |
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues;
MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp,
Tcl_Obj *tailcallPtr);
MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
/* These two can be considered for the public api */
MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp);
MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp);
/*
* This structure holds the data for the various iteration callbacks used to
* NRE the 'for' and 'while' commands. We need a separate structure because we
* have more than the 4 client data entries we can provide directly thorugh
* the callback API. It is the 'word' information which puts us over the
* limit. It is needed because the loop body is argument 4 of 'for' and
* argument 2 of 'while'. Not providing the correct index confuses the #280
* code. We TclSmallAlloc/Free this.
*/
typedef struct ForIterData {
Tcl_Obj *cond; /* Loop condition expression. */
Tcl_Obj *body; /* Loop body. */
Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
const char *msg; /* Error message part. */
Tcl_Size word; /* Index of the body script in the command */
} ForIterData;
/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
* and Tcl_FindSymbol. This structure corresponds to an opaque
* typedef in tcl.h */
typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
const char* symbol);
struct Tcl_LoadHandle_ {
void *clientData; /* Client data is the load handle in the
* native filesystem if a module was loaded
* there, or an opaque pointer to a structure
* for further bookkeeping on load-from-VFS
* and load-from-memory */
TclFindSymbolProc* findSymbolProcPtr;
/* Procedure that resolves symbols in a
* loaded module */
Tcl_FSUnloadFileProc* unloadFileProcPtr;
/* Procedure that unloads a loaded module */
};
/* Flags for conversion of doubles to digit strings */
#define TCL_DD_E_FORMAT 0x2 /* Use a fixed-length string of digits,
* suitable for E format*/
#define TCL_DD_F_FORMAT 0x3 /* Use a fixed number of digits after the
* decimal point, suitable for F format */
#define TCL_DD_SHORTEST 0x4 /* Use the shortest possible string */
#define TCL_DD_NO_QUICK 0x8 /* Debug flag: forbid quick FP conversion */
#define TCL_DD_CONVERSION_TYPE_MASK 0x3
/* Mask to isolate the conversion type */
/*
*----------------------------------------------------------------
* Procedures shared among Tcl modules but not used by the outside world:
*----------------------------------------------------------------
*/
#if TCL_MAJOR_VERSION > 8
MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next,
int loc);
MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start,
const char *end);
MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, Tcl_Size len);
MODULE_SCOPE void TclAppendUtfToUtf(Tcl_Obj *objPtr,
const char *bytes, Tcl_Size numBytes);
MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], Tcl_Size objc, CmdFrame *cf);
MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
Tcl_Obj *objv[], Tcl_Size objc);
MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], Tcl_Size objc,
void *codePtr, CmdFrame *cfPtr, Tcl_Size cmd,
Tcl_Size pc);
MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
CmdFrame *cfPtr);
MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId,
void *clientData, int *flagPtr, int value);
MODULE_SCOPE void TclAsyncMarkFromNotifier(void);
|
| ︙ | ︙ | |||
3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 | 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; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num, Tcl_Size *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, Tcl_Size start, Tcl_Size *clNext); | > | 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 | 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 int TclChanIsBinary(Tcl_Channel chan); MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num, Tcl_Size *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, Tcl_Size start, Tcl_Size *clNext); |
| ︙ | ︙ | |||
3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 | MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE Tcl_Size TclDictGetSize(Tcl_Obj *dictPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags, Tcl_Size line, Tcl_Size *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; | > > > > > > > > > | 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 | MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE Tcl_Size TclDictGetSize(Tcl_Obj *dictPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *literalPtr); MODULE_SCOPE Tcl_Obj * TclDictObjSmartRef(Tcl_Interp *interp, Tcl_Obj *); MODULE_SCOPE int TclDictGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, Tcl_Obj **valuePtrPtr); MODULE_SCOPE int TclDictPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, Tcl_Obj *valuePtr); MODULE_SCOPE int TclDictPutString(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, const char *value); MODULE_SCOPE int TclDictRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags, Tcl_Size line, Tcl_Size *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; |
| ︙ | ︙ | |||
3305 3306 3307 3308 3309 3310 3311 | MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, void *clientData); MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, | | > | 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 | MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, void *clientData); MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); |
| ︙ | ︙ | |||
3351 3352 3353 3354 3355 3356 3357 | Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); | < < < | | > > | 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 | Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, Tcl_Size objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, Tcl_Size *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *prefix); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); MODULE_SCOPE int TclCompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE size_t TclHashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); |
| ︙ | ︙ | |||
3423 3424 3425 3426 3427 3428 3429 | MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); | | | | | | | | > | > | | 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 | MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, Tcl_Size numBytes, Tcl_Size *readPtr, char *dst); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, Tcl_Size numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, Tcl_Size numBytes, Tcl_Parse *parsePtr); MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(Tcl_Interp *interp, int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, Tcl_Size len); MODULE_SCOPE Tcl_Obj * TclNewNamespaceObj(Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void * TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); MODULE_SCOPE int TclpDeleteFile(const void *path); MODULE_SCOPE void TclpDeleteFileHandler(int fd); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); #ifdef _WIN32 MODULE_SCOPE void TclInitSockets(void); #else #define TclInitSockets() /* do nothing */ #endif struct addrinfo; /* forward declaration, needed for TclCreateSocketAddress */ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, TCL_HASH_TYPE stackSize, int flags); MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void * TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpGlobalLock(void); MODULE_SCOPE void TclpGlobalUnlock(void); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); |
| ︙ | ︙ | |||
3541 3542 3543 3544 3545 3546 3547 | void *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, | | | 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 | void *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, TCL_HASH_TYPE numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); |
| ︙ | ︙ | |||
3567 3568 3569 3570 3571 3572 3573 | MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count, int *tokensLeftPtr, Tcl_Size line, Tcl_Size *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, | | > | | | | | | | | | | | | 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 |
MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes,
Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr,
Tcl_InterpState *statePtr);
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
Tcl_Size count, int *tokensLeftPtr, Tcl_Size line,
Tcl_Size *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes,
const char *trim, Tcl_Size numTrim,
Tcl_Size *trimRight);
MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes,
const char *trim, Tcl_Size numTrim);
MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes,
const char *trim, Tcl_Size numTrim);
MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
MODULE_SCOPE int TclObjInterpProc(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE void TclRegisterCommandTypeName(
Tcl_ObjCmdProc *implementationProc,
const char *nameStr);
MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCount(int ch);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval);
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void * TclpLoadMemoryGetBuffer(size_t size);
MODULE_SCOPE int TclpLoadMemory(void *buffer, size_t size,
Tcl_Size codeSize, const char *path, Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
#endif
MODULE_SCOPE void TclInitThreadStorage(void);
MODULE_SCOPE void TclFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
#ifdef TCL_WIDE_CLICKS
MODULE_SCOPE long long TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(long long clicks);
MODULE_SCOPE double TclpWideClickInMicrosec(void);
#else
# ifdef _WIN32
# define TCL_WIDE_CLICKS 1
MODULE_SCOPE long long TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClickInMicrosec(void);
# define TclpWideClicksToNanoseconds(clicks) \
((double)(clicks) * TclpWideClickInMicrosec() * 1000)
# endif
#endif
MODULE_SCOPE long long TclpGetMicroseconds(void);
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr);
MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp,
const char *msg, Tcl_Size length);
/* Tip 430 */
MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp);
MODULE_SCOPE int TclIsZipfsPath(const char *path);
MODULE_SCOPE void TclZipfsFinalize(void);
/*
* Many parsing tasks need a common definition of whitespace.
* Use this routine and macro to achieve that and place
* optimization (fragile on changes) in one place.
*/
MODULE_SCOPE int TclIsSpaceProc(int byte);
#define TclIsSpaceProcM(byte) \
(((byte) > 0x20) ? 0 : TclIsSpaceProc(byte))
/*
*----------------------------------------------------------------
* Command procedures in the generic core:
*----------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 | MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; /* Assemble command function */ MODULE_SCOPE Tcl_ObjCmdProc Tcl_AssembleObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRAssembleObjCmd; MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd; | > | 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 | MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclLoadIcuObjCmd; /* Assemble command function */ MODULE_SCOPE Tcl_ObjCmdProc Tcl_AssembleObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRAssembleObjCmd; MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd; |
| ︙ | ︙ | |||
4002 4003 4004 4005 4006 4007 4008 | MODULE_SCOPE int TclFullFinalizationRequested(void); /* * TIP #542 */ | | | | | | | | < | 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 | MODULE_SCOPE int TclFullFinalizationRequested(void); /* * TIP #542 */ MODULE_SCOPE size_t TclUniCharLen(const Tcl_UniChar *uniStr); MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); MODULE_SCOPE int TclUniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); MODULE_SCOPE int TclUniCharCaseMatch(const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* * Just for the purposes of command-type registration. */ MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; |
| ︙ | ︙ | |||
4047 4048 4049 4050 4051 4052 4053 | } TclProcessWaitStatus; MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, int *codePtr, Tcl_Obj **msgObjPtr, Tcl_Obj **errorObjPtr); | | | > | | | 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 | } TclProcessWaitStatus; MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, int *codePtr, Tcl_Obj **msgObjPtr, Tcl_Obj **errorObjPtr); MODULE_SCOPE int TclClose(Tcl_Interp *, Tcl_Channel chan); /* * TIP #508: [array default] */ MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); /* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, int before, int after, int *indexPtr); MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); /* * Error message utility functions */ 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 |
| ︙ | ︙ | |||
4153 4154 4155 4156 4157 4158 4159 |
# define TclIncrObjsFreed() \
tclObjsFreed++
#else
# define TclIncrObjsAllocated()
# define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */
| | | | | | | | | | | | | | | | | | | | | | | 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 |
# define TclIncrObjsFreed() \
tclObjsFreed++
#else
# define TclIncrObjsAllocated()
# define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */
# define TclAllocObjStorage(objPtr) \
TclAllocObjStorageEx(NULL, (objPtr))
# define TclFreeObjStorage(objPtr) \
TclFreeObjStorageEx(NULL, (objPtr))
#ifndef TCL_MEM_DEBUG
# define TclNewObj(objPtr) \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering) with
* 'length == TCL_INDEX_NONE'.
* Use empty 'if ; else' to handle use in unbraced outer if/else conditions.
*/
# define TclDecrRefCount(objPtr) \
if ((objPtr)->refCount-- > 1) ; else { \
if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
&& ((objPtr)->bytes != &tclEmptyString)) { \
Tcl_Free((objPtr)->bytes); \
} \
(objPtr)->length = TCL_INDEX_NONE; \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
} else { \
TclFreeObj(objPtr); \
} \
}
#if TCL_THREADS && !defined(USE_THREAD_ALLOC)
# define USE_THREAD_ALLOC 1
#endif
#if defined(PURIFY)
|
| ︙ | ︙ | |||
4296 4297 4298 4299 4300 4301 4302 |
(objPtr) = tclFreeObjList; \
tclFreeObjList = (Tcl_Obj *) \
tclFreeObjList->internalRep.twoPtrValue.ptr1; \
Tcl_MutexUnlock(&tclObjMutex); \
} while (0)
# define TclFreeObjStorageEx(interp, objPtr) \
| | | | | | 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 |
(objPtr) = tclFreeObjList; \
tclFreeObjList = (Tcl_Obj *) \
tclFreeObjList->internalRep.twoPtrValue.ptr1; \
Tcl_MutexUnlock(&tclObjMutex); \
} while (0)
# define TclFreeObjStorageEx(interp, objPtr) \
do { \
Tcl_MutexLock(&tclObjMutex); \
(objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \
tclFreeObjList = (objPtr); \
Tcl_MutexUnlock(&tclObjMutex); \
} while (0)
#endif
#else /* TCL_MEM_DEBUG */
MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
int line);
|
| ︙ | ︙ | |||
4351 4352 4353 4354 4355 4356 4357 | * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); * MODULE_SCOPE void TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); * *---------------------------------------------------------------- */ #define TclInitEmptyStringRep(objPtr) \ | | < | | | | | | | | | | | | > > > > > | | | | | | | | | | | | | | 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 |
* MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
* MODULE_SCOPE void TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
*
*----------------------------------------------------------------
*/
#define TclInitEmptyStringRep(objPtr) \
((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
TclInitEmptyStringRep(objPtr); \
} else { \
(objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \
memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
#define TclAttemptInitStringRep(objPtr, bytePtr, len) \
((((len) == 0) ? ( \
TclInitEmptyStringRep(objPtr) \
) : ( \
(objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \
(objPtr)->length = ((objPtr)->bytes) ? \
(memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \
(objPtr)->bytes[len] = '\0', (len)) : (-1) \
)), (objPtr)->bytes)
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's byte array
* pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The
* macro's expression result is the string rep's byte pointer which might be
* NULL. The bytes referenced by this pointer must not be modified by the
* caller. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
: (Tcl_GetStringFromObj)((objPtr), (lenPtr)))
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's internal
* representation. Does not actually reset the rep's bytes. The ANSI C
* "prototype" for this macro is:
*
* MODULE_SCOPE void TclFreeInternalRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclFreeInternalRep(objPtr) \
if ((objPtr)->typePtr != NULL) { \
if ((objPtr)->typePtr->freeIntRepProc != NULL) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
} \
(objPtr)->typePtr = NULL; \
}
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's string representation.
* The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclInvalidateStringRep(objPtr) \
do { \
Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \
if (_isobjPtr->bytes != NULL) { \
if (_isobjPtr->bytes != &tclEmptyString) { \
Tcl_Free((void *)_isobjPtr->bytes); \
} \
_isobjPtr->bytes = NULL; \
} \
} while (0)
/*
* These form part of the native filesystem support. They are needed here
* because we have a few native filesystem functions (which are the same for
* win/unix) in this file.
*/
|
| ︙ | ︙ | |||
4467 4468 4469 4470 4471 4472 4473 |
*
* MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
*----------------------------------------------------------------
*/
#define TclUnpackBignum(objPtr, bignum) \
do { \
| | | | 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 |
*
* MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
*----------------------------------------------------------------
*/
#define TclUnpackBignum(objPtr, bignum) \
do { \
Tcl_Obj *bignumObj = (objPtr); \
int bignumPayload = \
PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
if (bignumPayload == -1) { \
(bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
} else { \
(bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \
(bignum).sign = bignumPayload >> 30; \
(bignum).alloc = (bignumPayload >> 15) & 0x7FFF; \
|
| ︙ | ︙ | |||
4521 4522 4523 4524 4525 4526 4527 |
Tcl_Size allocated = 2 * _needed; \
Tcl_Token *oldPtr = (tokenPtr); \
Tcl_Token *newPtr; \
if (oldPtr == (staticPtr)) { \
oldPtr = NULL; \
} \
newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr, \
| | | | | 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 |
Tcl_Size allocated = 2 * _needed; \
Tcl_Token *oldPtr = (tokenPtr); \
Tcl_Token *newPtr; \
if (oldPtr == (staticPtr)) { \
oldPtr = NULL; \
} \
newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr, \
allocated * sizeof(Tcl_Token)); \
if (newPtr == NULL) { \
allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \
newPtr = (Tcl_Token *)Tcl_Realloc((char *) oldPtr, \
allocated * sizeof(Tcl_Token)); \
} \
(available) = allocated; \
if (oldPtr == NULL) { \
memcpy(newPtr, staticPtr, \
(used) * sizeof(Tcl_Token)); \
} \
(tokenPtr) = newPtr; \
} \
} while (0)
#define TclGrowParseTokenArray(parsePtr, append) \
TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens, \
|
| ︙ | ︙ | |||
4553 4554 4555 4556 4557 4558 4559 | * string handling. The macro's expression result is 1 for the 1-byte case or * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ | < | | < < < < < < | | | | | | | | | | | | < | 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 |
* string handling. The macro's expression result is 1 for the 1-byte case or
* the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch);
*----------------------------------------------------------------
*/
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToUniChar(str, chPtr))
/*
*----------------------------------------------------------------
* Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
* -sensitive points where it pays to avoid a function call in the common case
* of counting along a string of all one-byte characters. The ANSI C
* "prototype" for this macro is:
*
* MODULE_SCOPE void TclNumUtfCharsM(Tcl_Size numChars, const char *bytes,
* Tcl_Size numBytes);
* numBytes must be >= 0
*----------------------------------------------------------------
*/
#define TclNumUtfCharsM(numChars, bytes, numBytes) \
do { \
Tcl_Size _count, _i = (numBytes); \
unsigned char *_str = (unsigned char *) (bytes); \
while (_i > 0 && (*_str < 0xC0)) { _i--; _str++; } \
_count = (numBytes) - _i; \
if (_i) { \
_count += Tcl_NumUtfChars((bytes) + _count, _i); \
} \
(numChars) = _count; \
} while (0);
/*
*----------------------------------------------------------------
* Macro that encapsulates the logic that determines when it is safe to
* interpret a string as a byte array directly. In summary, the object must be
* a byte array and must not have a string representation (as the operations
* that it is used in are defined on strings, not byte arrays). Theoretically
* it is possible to also be efficient in the case where the object's bytes
* field is filled by generation from the byte array (c.f. list canonicality)
* but we don't do that at the moment since this is purely about efficiency.
* The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
#define TclIsPureDict(objPtr) \
(((objPtr)->bytes == NULL) && TclHasInternalRep((objPtr), &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);
|
| ︙ | ︙ | |||
4658 4659 4660 4661 4662 4663 4664 | MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; | < | 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 | MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; /* *---------------------------------------------------------------- * Macro used by the Tcl core to check whether a pattern has any characters * special to [string match]. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclMatchIsTrivial(const char *pattern); *---------------------------------------------------------------- |
| ︙ | ︙ | |||
4684 4685 4686 4687 4688 4689 4690 | * * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ #define TclSetIntObj(objPtr, i) \ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 |
*
* MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
*----------------------------------------------------------------
*/
#define TclSetIntObj(objPtr, i) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \
} while (0)
#define TclSetDoubleObj(objPtr, d) \
do { \
Tcl_ObjInternalRep ir; \
ir.doubleValue = (double) d; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and initialise objects of standard
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, Tcl_Size len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
#ifndef TCL_MEM_DEBUG
#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewUIntObj(objPtr, uw) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
Tcl_WideUInt uw_ = (uw); \
if (uw_ > WIDE_MAX) { \
mp_int bignumValue_; \
if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \
Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \
} \
TclSetBignumInternalRep((objPtr), &bignumValue_); \
} else { \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
(objPtr)->typePtr = &tclIntType; \
} \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewIndexObj(objPtr, w) \
TclNewIntObj(objPtr, w)
#define TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.doubleValue = (double)(d); \
(objPtr)->typePtr = &tclDoubleType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewStringObj(objPtr, s, len) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
TclInitStringRep((objPtr), (s), (len)); \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#else /* TCL_MEM_DEBUG */
#define TclNewIntObj(objPtr, w) \
(objPtr) = Tcl_NewWideIntObj(w)
#define TclNewUIntObj(objPtr, uw) \
do { \
Tcl_WideUInt uw_ = (uw); \
if (uw_ > WIDE_MAX) { \
mp_int bignumValue_; \
if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \
(objPtr) = Tcl_NewBignumObj(&bignumValue_); \
} else { \
(objPtr) = NULL; \
} \
} else { \
(objPtr) = Tcl_NewWideIntObj(uw_); \
} \
} while (0)
#define TclNewIndexObj(objPtr, w) \
TclNewIntObj(objPtr, w)
#define TclNewDoubleObj(objPtr, d) \
(objPtr) = Tcl_NewDoubleObj(d)
|
| ︙ | ︙ | |||
4837 4838 4839 4840 4841 4842 4843 | /* *---------------------------------------------------------------- * Inline version of TclCleanupCommand; still need the function as it is in * the internal stubs, but the core can use the macro instead. */ | | < | | | | | | | | < | > | | 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 |
/*
*----------------------------------------------------------------
* Inline version of TclCleanupCommand; still need the function as it is in
* the internal stubs, but the core can use the macro instead.
*/
#define TclCleanupCommandMacro(cmdPtr) \
do { \
if ((cmdPtr)->refCount-- <= 1) { \
Tcl_Free(cmdPtr); \
} \
} while (0)
/*
* inside this routine crement refCount first incase cmdPtr is replacing itself
*/
#define TclRoutineAssign(location, cmdPtr) \
do { \
(cmdPtr)->refCount++; \
if ((location) != NULL \
&& (location--) <= 1) { \
Tcl_Free(((location))); \
} \
(location) = (cmdPtr); \
} while (0)
#define TclRoutineHasName(cmdPtr) \
((cmdPtr)->hPtr != NULL)
/*
*----------------------------------------------------------------
* Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number
* of calls out of the critical path. Note that this code isn't particularly
* readable; the non-inline version (in tclInterp.c) is much easier to
* understand. Note also that these macros takes different args (iPtr->limit)
* to the non-inline version.
*/
#define TclLimitExceeded(limit) \
((limit).exceeded != 0)
#define TclLimitReady(limit) \
(((limit).active == 0) ? 0 : \
(++(limit).granularityTicker, \
((((limit).active & TCL_LIMIT_COMMANDS) && \
(((limit).cmdGranularity == 1) || \
((limit).granularityTicker % (limit).cmdGranularity == 0))) \
? 1 : \
(((limit).active & TCL_LIMIT_TIME) && \
|
| ︙ | ︙ | |||
4991 4992 4993 4994 4995 4996 4997 |
typedef struct NRE_callback {
Tcl_NRPostProc *procPtr;
void *data[4];
struct NRE_callback *nextPtr;
} NRE_callback;
| > | | 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 |
typedef struct NRE_callback {
Tcl_NRPostProc *procPtr;
void *data[4];
struct NRE_callback *nextPtr;
} NRE_callback;
#define TOP_CB(iPtr) \
(((Interp *)(iPtr))->execEnvPtr->callbackPtr)
/*
* Inline version of Tcl_NRAddCallback.
*/
#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \
do { \
|
| ︙ | ︙ | |||
5030 5031 5032 5033 5034 5035 5036 | #define NRE_ASSERT(expr) #endif #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) | | | | | 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 | #define NRE_ASSERT(expr) #endif #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) #define Tcl_AttemptAlloc TclpAlloc #define Tcl_AttemptRealloc TclpRealloc #define Tcl_Free TclpFree #endif /* * Special hack for macOS, where the static linker (technically the 'ar' * command) hates empty object files, and accepts no flags to make it shut up. * * These symbols are otherwise completely useless. |
| ︙ | ︙ |
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 39 */ EXTERN Tcl_ObjCmdProc * TclGetObjInterpProc(void); /* 40 */ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 39 */ EXTERN Tcl_ObjCmdProc * TclGetObjInterpProc(void); /* 40 */ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *modeFlagsPtr); /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ EXTERN const char * TclpGetUserHome(const char *name, Tcl_DString *bufferPtr); /* 43 */ EXTERN Tcl_ObjCmdProc2 * TclGetObjInterpProc2(void); |
| ︙ | ︙ | |||
616 617 618 619 620 621 622 |
void (*reserved33)(void);
void (*reserved34)(void);
void (*reserved35)(void);
void (*reserved36)(void);
void (*reserved37)(void);
int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */
| | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
void (*reserved33)(void);
void (*reserved34)(void);
void (*reserved35)(void);
void (*reserved36)(void);
void (*reserved37)(void);
int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */
int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *modeFlagsPtr); /* 40 */
Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
Tcl_ObjCmdProc2 * (*tclGetObjInterpProc2) (void); /* 43 */
void (*reserved44)(void);
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
void (*reserved47)(void);
|
| ︙ | ︙ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
* This is used by alias deletion to remove
* the alias from the child interpreter alias
* table. */
struct Target *targetPtr; /* Entry for target command in parent. This is
* used in the parent interpreter to map back
* from the target command to aliases
* redirecting to it. */
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
* This is used by alias deletion to remove
* the alias from the child interpreter alias
* table. */
struct Target *targetPtr; /* Entry for target command in parent. This is
* used in the parent interpreter to map back
* from the target command to aliases
* redirecting to it. */
Tcl_Size objc; /* Count of Tcl_Obj in the prefix of the
* target command to be invoked in the target
* interpreter. Additional arguments specified
* when calling the alias in the child interp
* will be appended to the prefix before the
* command is invoked. */
Tcl_Obj *objPtr; /* The first actual prefix object - the target
* command name; this has to be at the end of
|
| ︙ | ︙ | |||
133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
Target *targetsPtr; /* The head of a doubly-linked list of all the
* target records which denote aliases from
* children or sibling interpreters that direct
* to commands in this interpreter. This list
* is used to remove dangling pointers from
* the child (or sibling) interpreters when
* this interpreter is deleted. */
} Parent;
/*
* The following structure keeps track of all the Parent and Child information
* on a per-interp basis.
*/
| > > > > | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
Target *targetsPtr; /* The head of a doubly-linked list of all the
* target records which denote aliases from
* children or sibling interpreters that direct
* to commands in this interpreter. This list
* is used to remove dangling pointers from
* the child (or sibling) interpreters when
* this interpreter is deleted. */
Tcl_Size idIssuer; /* Used to issue a sequence of names for
* "unnamed" child interpreters. We keep a
* count here to avoid having to scan over IDs
* for interpreters that we've already used. */
} Parent;
/*
* The following structure keeps track of all the Parent and Child information
* on a per-interp basis.
*/
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
* TIP#143 limit handler internal representation.
*/
struct LimitHandler {
int flags; /* The state of this particular handler. */
Tcl_LimitHandlerProc *handlerProc;
/* The handler callback. */
| | > > | | | | | | | | < < | > > > > | | | | | | | | | | | | | | | | < | 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 |
* TIP#143 limit handler internal representation.
*/
struct LimitHandler {
int flags; /* The state of this particular handler. */
Tcl_LimitHandlerProc *handlerProc;
/* The handler callback. */
void *clientData; /* Opaque argument to the handler callback. */
Tcl_LimitHandlerDeleteProc *deleteProc;
/* How to delete the clientData. */
LimitHandler *prevPtr; /* Previous item in linked list of
* handlers. */
LimitHandler *nextPtr; /* Next item in linked list of handlers. */
};
/*
* Values for the LimitHandler flags field.
*/
enum LimitHandlerFlags {
LIMIT_HANDLER_ACTIVE = 1, /* The handler is currently being processed;
* handlers are never to be reentered. */
LIMIT_HANDLER_DELETED = 2 /* The handler has been deleted. This should
* not normally be observed because when a
* handler is deleted it is also spliced out of
* the list of handlers, but even so we will be
* careful.*/
};
/*
* Macro to make looking up child and parent info more convenient.
*/
#define INTERP_INFO(interp) \
((InterpInfo *) ((Interp *) (interp))->interpInfo)
/*
* Prototypes for local static functions:
*/
static int AliasCreate(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
Tcl_Obj *const objv[]);
static int AliasDelete(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Obj *namePtr);
static int AliasDescribe(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Obj *objPtr);
static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp);
static Tcl_ObjCmdProc AliasNRCmd;
static Tcl_CmdDeleteProc AliasObjCmdDeleteProc;
static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static Tcl_Interp * GetInterp2(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[]);
static Tcl_InterpDeleteProc InterpInfoDeleteProc;
static int ChildBgerror(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Size objc,
Tcl_Obj *const objv[]);
static Tcl_Interp * ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int safe);
static int ChildDebugCmd(Tcl_Interp *interp,
Tcl_Interp *childInterp,
Tcl_Size objc, Tcl_Obj *const objv[]);
static int ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp,
Tcl_Size objc, Tcl_Obj *const objv[]);
static int ChildExpose(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Size objc,
Tcl_Obj *const objv[]);
static int ChildHide(Tcl_Interp *interp, Tcl_Interp *childInterp,
Tcl_Size objc, Tcl_Obj *const objv[]);
static int ChildHidden(Tcl_Interp *interp,
Tcl_Interp *childInterp);
static int ChildInvokeHidden(Tcl_Interp *interp,
Tcl_Interp *childInterp,
const char *namespaceName,
Tcl_Size objc, Tcl_Obj *const objv[]);
static int ChildMarkTrusted(Tcl_Interp *interp,
Tcl_Interp *childInterp);
static Tcl_CmdDeleteProc ChildObjCmdDeleteProc;
static int ChildRecursionLimit(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Size objc,
Tcl_Obj *const objv[]);
static int ChildCommandLimitCmd(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Size consumedObjc,
Tcl_Size objc, Tcl_Obj *const objv[]);
static int ChildTimeLimitCmd(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Size consumedObjc,
Tcl_Size objc, Tcl_Obj *const objv[]);
static void InheritLimitsFromParent(Tcl_Interp *childInterp,
Tcl_Interp *parentInterp);
static void SetScriptLimitCallback(Tcl_Interp *interp, int type,
Tcl_Interp *targetInterp, Tcl_Obj *scriptObj);
static void CallScriptLimitCallback(void *clientData,
Tcl_Interp *interp);
static void DeleteScriptLimitCallback(void *clientData);
static void MakeSafe(Tcl_Interp *interp);
static void RunLimitHandlers(LimitHandler *handlerPtr,
Tcl_Interp *interp);
static void TimeLimitCallback(void *clientData);
/* NRE enabling */
static Tcl_NRPostProc NRPostInvokeHidden;
static Tcl_ObjCmdProc NRInterpCmd;
static Tcl_ObjCmdProc NRChildCmd;
/*
*----------------------------------------------------------------------
*
* Tcl_SetPreInitScript --
*
* This routine is used to change the value of the internal variable,
|
| ︙ | ︙ | |||
320 321 322 323 324 325 326 | * * Side effects: * Depends on what's in the init.tcl script. * *---------------------------------------------------------------------- */ | < < < < < > > > > > > > > > > > > | | > | 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 |
*
* Side effects:
* Depends on what's in the init.tcl script.
*
*----------------------------------------------------------------------
*/
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
/*
* Splice for putting the "tcl" package in the list of packages while the
* pre-init and init scripts are running. The real version of this struct
* is in tclPkg.c.
*/
typedef struct PkgName {
struct PkgName *nextPtr;/* Next in list of package names being
* initialized. */
char name[4]; /* Enough space for "tcl". The *real* version
* of this structure uses a flex array. */
} PkgName;
PkgName pkgName = {NULL, "tcl"};
PkgName **names = (PkgName **) TclInitPkgFiles(interp);
int result = TCL_ERROR;
pkgName.nextPtr = *names;
*names = &pkgName;
if (tclPreInitScript != NULL) {
if (Tcl_EvalEx(interp, tclPreInitScript, TCL_INDEX_NONE,
0 /*flags*/) == TCL_ERROR) {
goto end;
}
}
/*
* In order to find init.tcl during initialization, the following script
* is invoked by Tcl_Init(). It looks in several different directories:
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
" lappend scripts [list lindex \\$tcl_libPath $i]\n"
" }\n"
" }\n"
" }\n"
" set dirs {}\n"
" set errors {}\n"
" foreach script $scripts {\n"
| < | > | | | 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 |
" lappend scripts [list lindex \\$tcl_libPath $i]\n"
" }\n"
" }\n"
" }\n"
" set dirs {}\n"
" set errors {}\n"
" foreach script $scripts {\n"
" if {[set tcl_library [eval $script]] eq \"\"} continue\n"
" set tclfile [file join $tcl_library init.tcl]\n"
" if {[file exists $tclfile]} {\n"
" if {[catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"
" append errors \"$tclfile: $msg\n\"\n"
" append errors \"[dict get $opts -errorinfo]\n\"\n"
" continue\n"
" }\n"
" unset -nocomplain tclDefaultLibrary\n"
" return\n"
" }\n"
" lappend dirs $tcl_library\n"
" }\n"
" unset -nocomplain tclDefaultLibrary\n"
" set msg \"Cannot find a usable init.tcl in the following directories: \n\"\n"
" append msg \" $dirs\n\n\"\n"
" append msg \"$errors\n\n\"\n"
" append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
" error $msg\n"
" }\n"
"}\n"
"tclInit", TCL_INDEX_NONE, 0);
TclpSetInitialEncodings();
end:
*names = (*names)->nextPtr;
return result;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Parent *parentPtr;
Child *childPtr;
| | > | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 |
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Parent *parentPtr;
Child *childPtr;
interpInfoPtr = (InterpInfo *) Tcl_Alloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
parentPtr = &interpInfoPtr->parent;
Tcl_InitHashTable(&parentPtr->childTable, TCL_STRING_KEYS);
parentPtr->targetsPtr = NULL;
parentPtr->idIssuer = 0;
childPtr = &interpInfoPtr->child;
childPtr->parentInterp = NULL;
childPtr->childEntryPtr = NULL;
childPtr->childInterp = interp;
childPtr->interpCmd = NULL;
Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS);
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
static void
InterpInfoDeleteProc(
TCL_UNUSED(void *),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* child interps should already be deleted. */
{
| | < < > | 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 |
static void
InterpInfoDeleteProc(
TCL_UNUSED(void *),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* child interps should already be deleted. */
{
InterpInfo *interpInfoPtr = INTERP_INFO(interp);
Child *childPtr;
Parent *parentPtr;
Target *targetPtr;
/*
* There shouldn't be any commands left.
*/
parentPtr = &interpInfoPtr->parent;
if (parentPtr->childTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist commands");
}
Tcl_DeleteHashTable(&parentPtr->childTable);
/*
* Tell any interps that have aliases to this interp that they should
* delete those aliases. If the other interp was already dead, it would
* have removed the target record already.
*/
for (targetPtr = parentPtr->targetsPtr; targetPtr != NULL; ) {
Target *tmpPtr = targetPtr->nextPtr;
Tcl_DeleteCommandFromToken(targetPtr->childInterp,
targetPtr->childCmd);
targetPtr = tmpPtr;
}
childPtr = &interpInfoPtr->child;
if (childPtr->interpCmd != NULL) {
|
| ︙ | ︙ | |||
599 600 601 602 603 604 605 |
*
*----------------------------------------------------------------------
*/
int
Tcl_InterpObjCmd(
void *clientData,
| | | | | | | | 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 |
*
*----------------------------------------------------------------------
*/
int
Tcl_InterpObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}
static int
NRInterpCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *childInterp;
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
"eval", "exists", "expose", "hide",
"hidden", "issafe", "invokehidden",
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 653 654 655 656 657 |
OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE,
#ifndef TCL_NO_DEPRECATED
OPT_SLAVES,
#endif
OPT_TARGET, OPT_TRANSFER
} index;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
| > | | | < < < > | > > > | < < | 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 |
OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE,
#ifndef TCL_NO_DEPRECATED
OPT_SLAVES,
#endif
OPT_TARGET, OPT_TRANSFER
} index;
Tcl_Size i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(NULL, objv[1], options, NULL, 0,
&index) != TCL_OK) {
/* Don't report the "slaves" option as possibility */
Tcl_GetIndexFromObj(interp, objv[1], optionsNoSlaves,
"option", 0, &index);
return TCL_ERROR;
}
switch (index) {
case OPT_ALIAS: {
Tcl_Interp *parentInterp;
if (objc < 4) {
goto aliasArgs;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
if (objc == 4) {
return AliasDescribe(interp, childInterp, objv[3]);
}
if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) {
return AliasDelete(interp, childInterp, objv[3]);
}
if (objc > 5) {
parentInterp = GetInterp(interp, objv[4]);
if (parentInterp == NULL) {
return TCL_ERROR;
}
return AliasCreate(interp, childInterp, parentInterp, objv[3],
objv[5], objc - 6, objv + 6);
}
aliasArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"childPath childCmd ?parentPath parentCmd? ?arg ...?");
return TCL_ERROR;
}
case OPT_ALIASES:
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
return AliasList(interp, childInterp);
case OPT_BGERROR:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildBgerror(interp, childInterp, objc - 3, objv + 3);
case OPT_CANCEL: {
int flags = 0;
Tcl_Obj *resultObjPtr;
static const char *const cancelOptions[] = {
"-unwind", "--", NULL
};
enum optionCancelEnum {
OPT_UNWIND, OPT_LAST
} idx;
for (i = 2; i < objc; i++) {
if (TclGetString(objv[i])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option",
0, &idx) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
778 779 780 781 782 783 784 |
} else {
resultObjPtr = NULL;
}
return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags);
}
case OPT_CREATE: {
| | | 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 |
} else {
resultObjPtr = NULL;
}
return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags);
}
case OPT_CREATE: {
int last, safe;
Tcl_Obj *childPtr;
char buf[16 + TCL_INTEGER_SPACE];
static const char *const createOptions[] = {
"-safe", "--", NULL
};
enum option {
OPT_SAFE, OPT_LAST
|
| ︙ | ︙ | |||
819 820 821 822 823 824 825 826 827 828 829 830 831 832 |
}
if (i < objc) {
childPtr = objv[i];
}
}
buf[0] = '\0';
if (childPtr == NULL) {
/*
* Create an anonymous interpreter -- we choose its name and the
* name of the command. We check that the command name that we use
* for the interpreter does not collide with an existing command
* in the parent interpreter.
*/
| > > > < < | | > | < < < < | < < | | | 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 |
}
if (i < objc) {
childPtr = objv[i];
}
}
buf[0] = '\0';
if (childPtr == NULL) {
Parent *parentInfo = &INTERP_INFO(interp)->parent;
Tcl_CmdInfo cmdInfo;
/*
* Create an anonymous interpreter -- we choose its name and the
* name of the command. We check that the command name that we use
* for the interpreter does not collide with an existing command
* in the parent interpreter.
*/
do {
snprintf(buf, sizeof(buf), "interp%" TCL_SIZE_MODIFIER "d",
parentInfo->idIssuer++);
} while (Tcl_GetCommandInfo(interp, buf, &cmdInfo));
childPtr = Tcl_NewStringObj(buf, -1);
}
if (ChildCreate(interp, childPtr, safe) == NULL) {
Tcl_BounceRefCount(childPtr);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, childPtr);
return TCL_OK;
}
case OPT_DEBUG: /* TIP #378 */
/*
* Currently only -frame supported, otherwise ?-option ?value??
*/
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildDebugCmd(interp, childInterp, objc - 3, objv + 3);
case OPT_DELETE: {
InterpInfo *iiPtr;
for (i = 2; i < objc; i++) {
childInterp = GetInterp(interp, objv[i]);
if (childInterp == NULL) {
return TCL_ERROR;
} else if (childInterp == interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot delete the current interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"DELETESELF", (char *)NULL);
return TCL_ERROR;
}
iiPtr = INTERP_INFO(childInterp);
Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp,
iiPtr->child.interpCmd);
}
return TCL_OK;
}
case OPT_EVAL:
if (objc < 4) {
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 |
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp)));
return TCL_OK;
case OPT_INVOKEHID: {
| < | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp)));
return TCL_OK;
case OPT_INVOKEHID: {
const char *namespaceName;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
enum hiddenOption {
OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST
} idx;
|
| ︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 1014 1015 |
return TCL_ERROR;
}
switch (limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv);
}
}
| > > > < | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
return TCL_ERROR;
}
switch (limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv);
default:
Tcl_Panic("unreachable");
return TCL_ERROR;
}
}
case OPT_MARKTRUSTED:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 |
Tcl_HashSearch hashSearch;
char *string;
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
| | | | | 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 |
Tcl_HashSearch hashSearch;
char *string;
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
iiPtr = INTERP_INFO(childInterp);
TclNewObj(resultPtr);
hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
string = (char *) Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr);
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj(string, -1));
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
case OPT_TRANSFER:
case OPT_SHARE: {
Tcl_Interp *parentInterp; /* The parent of the child. */
Tcl_Channel chan;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "srcPath channel destPath");
return TCL_ERROR;
}
parentInterp = GetInterp(interp, objv[2]);
if (parentInterp == NULL) {
return TCL_ERROR;
}
chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL);
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 |
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
aliasName = TclGetString(objv[3]);
| | | | | > > > < | 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 |
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
aliasName = TclGetString(objv[3]);
iiPtr = INTERP_INFO(childInterp);
hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
aliasName, TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
(char *)NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"target interpreter for alias \"%s\" in path \"%s\" is "
"not my descendant", aliasName, TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"TARGETSHROUDED", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
default:
Tcl_Panic("unreachable");
return TCL_ERROR;
}
}
/*
*---------------------------------------------------------------------------
*
* GetInterp2 --
*
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
*---------------------------------------------------------------------------
*/
static Tcl_Interp *
GetInterp2(
Tcl_Interp *interp, /* Default interp if no interp was specified
* on the command line. */
| | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
*---------------------------------------------------------------------------
*/
static Tcl_Interp *
GetInterp2(
Tcl_Interp *interp, /* Default interp if no interp was specified
* on the command line. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc == 2) {
return interp;
} else if (objc == 3) {
return GetInterp(interp, objv[2]);
} else {
|
| ︙ | ︙ | |||
1194 1195 1196 1197 1198 1199 1200 |
int
Tcl_CreateAlias(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
| | | | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
int
Tcl_CreateAlias(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
Tcl_Size argc, /* How many additional arguments? */
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *childObjPtr, *targetObjPtr;
Tcl_Obj **objv;
Tcl_Size i;
int result;
objv = (Tcl_Obj **) TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc);
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
}
childObjPtr = Tcl_NewStringObj(childCmd, -1);
Tcl_IncrRefCount(childObjPtr);
|
| ︙ | ︙ | |||
1249 1250 1251 1252 1253 1254 1255 |
int
Tcl_CreateAliasObj(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
int
Tcl_CreateAliasObj(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
Tcl_Size objc, /* How many additional arguments? */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Tcl_Obj *childObjPtr, *targetObjPtr;
int result;
childObjPtr = Tcl_NewStringObj(childCmd, -1);
Tcl_IncrRefCount(childObjPtr);
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
targetObjPtr, objc, objv);
Tcl_DecrRefCount(childObjPtr);
Tcl_DecrRefCount(targetObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAliasObj --
*
* Object version: Gets information about an alias.
|
| ︙ | ︙ | |||
1353 1354 1355 1356 1357 1358 1359 |
int
Tcl_GetAliasObj(
Tcl_Interp *interp, /* Interp to start search from. */
const char *aliasName, /* Name of alias to find. */
Tcl_Interp **targetInterpPtr,
/* (Return) target interpreter. */
| | | | | | > | | | | 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 |
int
Tcl_GetAliasObj(
Tcl_Interp *interp, /* Interp to start search from. */
const char *aliasName, /* Name of alias to find. */
Tcl_Interp **targetInterpPtr,
/* (Return) target interpreter. */
const char **targetCmdPtr, /* (Return) name of target command. */
Tcl_Size *objcPtr, /* (Return) count of addnl args. */
Tcl_Obj ***objvPtr) /* (Return) additional args. */
{
InterpInfo *iiPtr = INTERP_INFO(interp);
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
Tcl_Size objc;
Tcl_Obj **objv;
hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
(char *)NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetCmdPtr != NULL) {
*targetCmdPtr = TclGetString(objv[0]);
}
if (objcPtr != NULL) {
*objcPtr = objc - 1;
}
if (objvPtr != NULL) {
*objvPtr = objv + 1;
}
|
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
/*
* OK, we are dealing with an alias, so traverse the chain of aliases. If
* we encounter the alias we are defining (or renaming to) any in the
* chain then we have a loop.
*/
| | | 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 |
/*
* OK, we are dealing with an alias, so traverse the chain of aliases. If
* we encounter the alias we are defining (or renaming to) any in the
* chain then we have a loop.
*/
aliasPtr = (Alias *) cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
Tcl_Obj *cmdNamePtr;
/*
* If the target of the next alias in the chain is the same as the
* source alias, we have a loop.
|
| ︙ | ︙ | |||
1474 1475 1476 1477 1478 1479 1480 |
}
aliasCmdPtr = (Command *) aliasCmd;
if (aliasCmdPtr == cmdPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot define or rename alias \"%s\": would create a loop",
Tcl_GetCommandName(cmdInterp, cmd)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
| | | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
}
aliasCmdPtr = (Command *) aliasCmd;
if (aliasCmdPtr == cmdPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot define or rename alias \"%s\": would create a loop",
Tcl_GetCommandName(cmdInterp, cmd)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"ALIASLOOP", (char *)NULL);
return TCL_ERROR;
}
/*
* Otherwise, follow the chain one step further. See if the target
* command is an alias - if so, follow the loop to its target command.
* Otherwise we do not have a loop.
*/
if (aliasCmdPtr->objProc != TclAliasObjCmd
&& aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
}
}
/*
*----------------------------------------------------------------------
*
* AliasCreate --
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 |
AliasCreate(
Tcl_Interp *interp, /* Interp for error reporting. */
Tcl_Interp *childInterp, /* Interp where alias cmd will live or from
* which alias will be deleted. */
Tcl_Interp *parentInterp, /* Interp in which target command will be
* invoked. */
Tcl_Obj *namePtr, /* Name of alias cmd. */
| | | | > | | | | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 |
AliasCreate(
Tcl_Interp *interp, /* Interp for error reporting. */
Tcl_Interp *childInterp, /* Interp where alias cmd will live or from
* which alias will be deleted. */
Tcl_Interp *parentInterp, /* Interp in which target command will be
* invoked. */
Tcl_Obj *namePtr, /* Name of alias cmd. */
Tcl_Obj *targetCmdPtr, /* Name of target cmd. */
Tcl_Size objc, /* Additional arguments to store */
Tcl_Obj *const objv[]) /* with alias. */
{
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
Target *targetPtr;
Child *childPtr;
Parent *parentPtr;
Tcl_Obj **prefv;
int isNew;
Tcl_Size i;
aliasPtr = (Alias *) Tcl_Alloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
aliasPtr->token = namePtr;
Tcl_IncrRefCount(aliasPtr->token);
aliasPtr->targetInterp = parentInterp;
aliasPtr->objc = objc + 1;
prefv = &aliasPtr->objPtr;
*prefv = targetCmdPtr;
Tcl_IncrRefCount(targetCmdPtr);
for (i = 0; i < objc; i++) {
*(++prefv) = objv[i];
Tcl_IncrRefCount(objv[i]);
}
Tcl_Preserve(childInterp);
Tcl_Preserve(parentInterp);
|
| ︙ | ︙ | |||
1569 1570 1571 1572 1573 1574 1575 | * careful to wipe out its client data first, so the command doesn't * try to delete itself. */ Command *cmdPtr; Tcl_DecrRefCount(aliasPtr->token); | | | 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 |
* careful to wipe out its client data first, so the command doesn't
* try to delete itself.
*/
Command *cmdPtr;
Tcl_DecrRefCount(aliasPtr->token);
Tcl_DecrRefCount(targetCmdPtr);
for (i = 0; i < objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
cmdPtr = (Command *) aliasPtr->childCmd;
cmdPtr->clientData = NULL;
cmdPtr->deleteProc = NULL;
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 |
return TCL_ERROR;
}
/*
* Make an entry in the alias table. If it already exists, retry.
*/
| | | 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 |
return TCL_ERROR;
}
/*
* Make an entry in the alias table. If it already exists, retry.
*/
childPtr = &INTERP_INFO(childInterp)->child;
while (1) {
Tcl_Obj *newToken;
const char *string;
string = TclGetString(aliasPtr->token);
hPtr = Tcl_CreateHashEntry(&childPtr->aliasTable, string, &isNew);
if (isNew != 0) {
|
| ︙ | ︙ | |||
1637 1638 1639 1640 1641 1642 1643 |
* because the alias may be pointing at a renamed alias, as in:
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
| | | | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 |
* because the alias may be pointing at a renamed alias, as in:
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
targetPtr = (Target *) Tcl_Alloc(sizeof(Target));
targetPtr->childCmd = aliasPtr->childCmd;
targetPtr->childInterp = childInterp;
parentPtr = &INTERP_INFO(parentInterp)->parent;
targetPtr->nextPtr = parentPtr->targetsPtr;
targetPtr->prevPtr = NULL;
if (parentPtr->targetsPtr != NULL) {
parentPtr->targetsPtr->prevPtr = targetPtr;
}
parentPtr->targetsPtr = targetPtr;
aliasPtr->targetPtr = targetPtr;
|
| ︙ | ︙ | |||
1689 1690 1691 1692 1693 1694 1695 |
/*
* If the alias has been renamed in the child, the parent can still use
* the original name (with which it was created) to find the alias to
* delete it.
*/
| | | | | 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 |
/*
* If the alias has been renamed in the child, the parent can still use
* the original name (with which it was created) to find the alias to
* delete it.
*/
childPtr = &INTERP_INFO(childInterp)->child;
hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", TclGetString(namePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS",
TclGetString(namePtr), (char *)NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1738 1739 1740 1741 1742 1743 1744 |
/*
* If the alias has been renamed in the child, the parent can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
| | | | 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 |
/*
* If the alias has been renamed in the child, the parent can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
childPtr = &INTERP_INFO(childInterp)->child;
hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
return TCL_OK;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1777 1778 1779 1780 1781 1782 1783 |
Tcl_HashEntry *entryPtr;
Tcl_HashSearch hashSearch;
Tcl_Obj *resultPtr;
Alias *aliasPtr;
Child *childPtr;
TclNewObj(resultPtr);
| | | | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 |
Tcl_HashEntry *entryPtr;
Tcl_HashSearch hashSearch;
Tcl_Obj *resultPtr;
Alias *aliasPtr;
Child *childPtr;
TclNewObj(resultPtr);
childPtr = &INTERP_INFO(childInterp)->child;
entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch);
for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token);
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1817 1818 1819 1820 1821 1822 1823 | * forwarded. * *---------------------------------------------------------------------- */ static int AliasNRCmd( | | | | | 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 |
* forwarded.
*
*----------------------------------------------------------------------
*/
static int
AliasNRCmd(
void *clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Alias *aliasPtr = (Alias *) clientData;
Tcl_Size prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
ListRep listRep;
int flags = TCL_EVAL_INVOKE;
/*
* Append the arguments to the command prefix and invoke the command in
|
| ︙ | ︙ | |||
1870 1871 1872 1873 1874 1875 1876 |
}
TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
int
TclAliasObjCmd(
| | | | > < | | | 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 |
}
TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
int
TclAliasObjCmd(
void *clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Alias *aliasPtr = (Alias *) clientData;
Tcl_Interp *targetInterp = aliasPtr->targetInterp;
int result;
Tcl_Size prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
int isRootEnsemble;
/*
* Append the arguments to the command prefix and invoke the command in
* the target interp's global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
Tcl_ResetResult(targetInterp);
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
/*
* Use the ensemble rewriting machinery to ensure correct error messages:
* only the source command should show, not the full target prefix.
*/
isRootEnsemble = TclInitRewriteEnsemble(targetInterp, 1, prefc, objv);
/*
* Protect the target interpreter if it isn't the same as the source
* interpreter so that we can continue to work with it after the target
* command completes.
*/
|
| ︙ | ︙ | |||
1935 1936 1937 1938 1939 1940 1941 |
result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
/*
* Clean up the ensemble rewrite info if we set it in the first place.
*/
if (isRootEnsemble) {
| | | 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 |
result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
/*
* Clean up the ensemble rewrite info if we set it in the first place.
*/
if (isRootEnsemble) {
TclResetRewriteEnsemble(targetInterp, 1);
}
/*
* If it was a cross-interpreter alias, we need to transfer the result
* back to the source interpreter and release the lock we previously set
* on the target interpreter.
*/
|
| ︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 |
}
return result;
#undef ALIAS_CMDV_PREALLOC
}
int
TclLocalAliasObjCmd(
| | | | > < | | | | 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 |
}
return result;
#undef ALIAS_CMDV_PREALLOC
}
int
TclLocalAliasObjCmd(
void *clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Alias *aliasPtr = (Alias *) clientData;
int result;
Tcl_Size prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
int isRootEnsemble;
/*
* Append the arguments to the command prefix and invoke the command in
* the global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
/*
* Use the ensemble rewriting machinery to ensure correct error messages:
* only the source command should show, not the full target prefix.
*/
isRootEnsemble = TclInitRewriteEnsemble(interp, 1, prefc, objv);
/*
* Execute the target command in the target interpreter.
*/
result = Tcl_EvalObjv(interp, cmdc, cmdv, TCL_EVAL_INVOKE);
/*
* Clean up the ensemble rewrite info if we set it in the first place.
*/
if (isRootEnsemble) {
TclResetRewriteEnsemble(interp, 1);
}
for (i=0; i<cmdc; i++) {
Tcl_DecrRefCount(cmdv[i]);
}
if (cmdv != cmdArr) {
TclStackFree(interp, cmdv);
|
| ︙ | ︙ | |||
2046 2047 2048 2049 2050 2051 2052 | * interpreter. * *---------------------------------------------------------------------- */ static void AliasObjCmdDeleteProc( | | | | < | | 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 |
* interpreter.
*
*----------------------------------------------------------------------
*/
static void
AliasObjCmdDeleteProc(
void *clientData) /* The alias record for this alias. */
{
Alias *aliasPtr = (Alias *) clientData;
Target *targetPtr;
Tcl_Size i;
Tcl_Obj **objv;
Tcl_DecrRefCount(aliasPtr->token);
objv = &aliasPtr->objPtr;
for (i = 0; i < aliasPtr->objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
/*
* Splice the target record out of the target interpreter's parent list.
*/
targetPtr = aliasPtr->targetPtr;
if (targetPtr->prevPtr != NULL) {
targetPtr->prevPtr->nextPtr = targetPtr->nextPtr;
} else {
Parent *parentPtr = &INTERP_INFO(aliasPtr->targetInterp)->parent;
parentPtr->targetsPtr = targetPtr->nextPtr;
}
if (targetPtr->nextPtr != NULL) {
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
|
| ︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 |
Tcl_Interp *interp) /* Get the parent of this interpreter. */
{
Child *childPtr; /* Child record of this interpreter. */
if (interp == NULL) {
return NULL;
}
| | | 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 |
Tcl_Interp *interp) /* Get the parent of this interpreter. */
{
Child *childPtr; /* Child record of this interpreter. */
if (interp == NULL) {
return NULL;
}
childPtr = &INTERP_INFO(interp)->child;
return childPtr->parentInterp;
}
/*
*----------------------------------------------------------------------
*
* TclSetChildCancelFlags --
|
| ︙ | ︙ | |||
2220 2221 2222 2223 2224 2225 2226 |
if (interp == NULL) {
return;
}
flags &= (CANCELED | TCL_CANCEL_UNWIND);
| | | | 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
if (interp == NULL) {
return;
}
flags &= (CANCELED | TCL_CANCEL_UNWIND);
parentPtr = &INTERP_INFO(interp)->parent;
hPtr = Tcl_FirstHashEntry(&parentPtr->childTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
childPtr = (Child *) Tcl_GetHashValue(hPtr);
iPtr = (Interp *) childPtr->childInterp;
if (iPtr == NULL) {
continue;
}
if (flags == 0) {
|
| ︙ | ︙ | |||
2272 2273 2274 2275 2276 2277 2278 | * None. * *---------------------------------------------------------------------- */ int Tcl_GetInterpPath( | | | | | > | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetInterpPath(
Tcl_Interp *interp, /* Interpreter to start search from. */
Tcl_Interp *targetInterp) /* Interpreter to find. */
{
InterpInfo *iiPtr;
if (targetInterp == interp) {
Tcl_SetObjResult(interp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = INTERP_INFO(targetInterp);
if (Tcl_GetInterpPath(interp, iiPtr->child.parentInterp) != TCL_OK) {
return TCL_ERROR;
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
Tcl_NewStringObj((const char *)
Tcl_GetHashKey(&iiPtr->parent.childTable,
iiPtr->child.childEntryPtr), -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetInterp --
|
| ︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 |
Tcl_HashEntry *hPtr; /* Search element. */
Child *childPtr; /* Interim child record. */
Tcl_Obj **objv;
Tcl_Size objc, i;
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *parentInfoPtr;
| | | | | | 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 |
Tcl_HashEntry *hPtr; /* Search element. */
Child *childPtr; /* Interim child record. */
Tcl_Obj **objv;
Tcl_Size objc, i;
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *parentInfoPtr;
if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
searchInterp = interp;
for (i = 0; i < objc; i++) {
parentInfoPtr = INTERP_INFO(searchInterp);
hPtr = Tcl_FindHashEntry(&parentInfoPtr->parent.childTable,
TclGetString(objv[i]));
if (hPtr == NULL) {
searchInterp = NULL;
break;
}
childPtr = (Child *) Tcl_GetHashValue(hPtr);
searchInterp = childPtr->childInterp;
if (searchInterp == NULL) {
break;
}
}
if (searchInterp == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not find interpreter \"%s\"", TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP",
TclGetString(pathPtr), (char *)NULL);
}
return searchInterp;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2374 2375 2376 2377 2378 2379 2380 |
*----------------------------------------------------------------------
*/
static int
ChildBgerror(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
| | | | | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 |
*----------------------------------------------------------------------
*/
static int
ChildBgerror(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
Tcl_Size objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
Tcl_Size length;
if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
|| (length < 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cmdPrefix must be list of length >= 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BGERRORFORMAT", (char *)NULL);
return TCL_ERROR;
}
TclSetBgErrorHandler(childInterp, objv[0]);
}
Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp));
return TCL_OK;
}
|
| ︙ | ︙ | |||
2428 2429 2430 2431 2432 2433 2434 |
InterpInfo *parentInfoPtr;
Tcl_HashEntry *hPtr;
const char *path;
int isNew;
Tcl_Size objc;
Tcl_Obj **objv;
| | | | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 |
InterpInfo *parentInfoPtr;
Tcl_HashEntry *hPtr;
const char *path;
int isNew;
Tcl_Size objc;
Tcl_Obj **objv;
if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
if (objc < 2) {
parentInterp = interp;
path = TclGetString(pathPtr);
} else {
Tcl_Obj *objPtr;
objPtr = Tcl_NewListObj(objc - 1, objv);
parentInterp = GetInterp(interp, objPtr);
Tcl_DecrRefCount(objPtr);
if (parentInterp == NULL) {
return NULL;
}
path = TclGetString(objv[objc - 1]);
}
if (safe == 0) {
safe = Tcl_IsSafe(parentInterp);
}
parentInfoPtr = INTERP_INFO(parentInterp);
hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path,
&isNew);
if (isNew == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"interpreter named \"%s\" already exists, cannot create",
path));
return NULL;
}
childInterp = Tcl_CreateInterp();
childPtr = &INTERP_INFO(childInterp)->child;
childPtr->parentInterp = parentInterp;
childPtr->childEntryPtr = hPtr;
childPtr->childInterp = childInterp;
childPtr->interpCmd = Tcl_NRCreateCommand(parentInterp, path,
TclChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc);
Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, childPtr);
|
| ︙ | ︙ | |||
2547 2548 2549 2550 2551 2552 2553 | * See user documentation for details. * *---------------------------------------------------------------------- */ int TclChildObjCmd( | | | | | 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 |
* See user documentation for details.
*
*----------------------------------------------------------------------
*/
int
TclChildObjCmd(
void *clientData, /* Child interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRChildCmd, clientData, objc, objv);
}
static int
NRChildCmd(
void *clientData, /* Child interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *childInterp = (Tcl_Interp *) clientData;
static const char *const options[] = {
"alias", "aliases", "bgerror", "debug",
"eval", "expose", "hide", "hidden",
"issafe", "invokehidden", "limit", "marktrusted",
"recursionlimit", NULL
};
enum childCmdOptionsEnum {
|
| ︙ | ︙ | |||
2660 2661 2662 2663 2664 2665 2666 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp)));
return TCL_OK;
case OPT_INVOKEHIDDEN: {
| | | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp)));
return TCL_OK;
case OPT_INVOKEHIDDEN: {
Tcl_Size i;
const char *namespaceName;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
enum hiddenOption {
OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST
} idx;
|
| ︙ | ︙ | |||
2683 2684 2685 2686 2687 2688 2689 |
return TCL_ERROR;
}
if (idx == OPT_GLOBAL) {
namespaceName = "::";
} else if (idx == OPT_NAMESPACE) {
if (++i == objc) { /* There must be more arguments. */
break;
| < < > | 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 |
return TCL_ERROR;
}
if (idx == OPT_GLOBAL) {
namespaceName = "::";
} else if (idx == OPT_NAMESPACE) {
if (++i == objc) { /* There must be more arguments. */
break;
}
namespaceName = TclGetString(objv[i]);
} else {
i++;
break;
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
|
| ︙ | ︙ | |||
2761 2762 2763 2764 2765 2766 2767 | * the child interpreter. * *---------------------------------------------------------------------- */ static void ChildObjCmdDeleteProc( | | | | | 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 |
* the child interpreter.
*
*----------------------------------------------------------------------
*/
static void
ChildObjCmdDeleteProc(
void *clientData) /* The ChildRecord for the command. */
{
Child *childPtr; /* Interim storage for Child record. */
Tcl_Interp *childInterp = (Tcl_Interp *) clientData;
/* And for a child interp. */
childPtr = &INTERP_INFO(childInterp)->child;
/*
* Unlink the child from its parent interpreter.
*/
Tcl_DeleteHashEntry(childPtr->childEntryPtr);
|
| ︙ | ︙ | |||
2809 2810 2811 2812 2813 2814 2815 |
*/
static int
ChildDebugCmd(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
| | | 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 |
*/
static int
ChildDebugCmd(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const debugTypes[] = {
"-frame", NULL
};
enum DebugTypes {
DEBUG_TYPE_FRAME
|
| ︙ | ︙ | |||
2880 2881 2882 2883 2884 2885 2886 |
*/
static int
ChildEval(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
| | | 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 |
*/
static int
ChildEval(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
/*
* TIP #285: If necessary, reset the cancellation flags for the child
* interpreter now; otherwise, canceling a script in a parent interpreter
|
| ︙ | ︙ | |||
2943 2944 2945 2946 2947 2948 2949 |
*----------------------------------------------------------------------
*/
static int
ChildExpose(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
| | | | 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 |
*----------------------------------------------------------------------
*/
static int
ChildExpose(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
const char *name;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot expose commands",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
(char *)NULL);
return TCL_ERROR;
}
name = TclGetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_ExposeCommand(childInterp, TclGetString(objv[0]),
name) != TCL_OK) {
Tcl_TransferResult(childInterp, TCL_ERROR, interp);
|
| ︙ | ︙ | |||
2987 2988 2989 2990 2991 2992 2993 |
*----------------------------------------------------------------------
*/
static int
ChildRecursionLimit(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
| | | | | | 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 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 |
*----------------------------------------------------------------------
*/
static int
ChildRecursionLimit(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
Tcl_Size objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
Interp *iPtr;
Tcl_WideInt limit;
if (objc) {
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
"safe interpreters cannot change recursion limit", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
(char *)NULL);
return TCL_ERROR;
}
if (TclGetWideIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
return TCL_ERROR;
}
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
(char *)NULL);
return TCL_ERROR;
}
Tcl_SetRecursionLimit(childInterp, limit);
iPtr = (Interp *) childInterp;
if (interp == childInterp && iPtr->numLevels > limit) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"falling back due to new recursion limit", -1));
Tcl_SetErrorCode(interp, "TCL", "RECURSION", (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(childInterp, 0);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
|
| ︙ | ︙ | |||
3049 3050 3051 3052 3053 3054 3055 |
*----------------------------------------------------------------------
*/
static int
ChildHide(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
| | | | 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 |
*----------------------------------------------------------------------
*/
static int
ChildHide(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
const char *name;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot hide commands",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
(char *)NULL);
return TCL_ERROR;
}
name = TclGetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_HideCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) {
Tcl_TransferResult(childInterp, TCL_ERROR, interp);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3093 3094 3095 3096 3097 3098 3099 |
*/
static int
ChildHidden(
Tcl_Interp *interp, /* Interp for data return. */
Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */
{
| | | | | | > | 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 |
*/
static int
ChildHidden(
Tcl_Interp *interp, /* Interp for data return. */
Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */
{
Tcl_Obj *listObjPtr; /* Local object pointer. */
Tcl_HashTable *hTblPtr; /* For local searches. */
Tcl_HashEntry *hPtr; /* For local searches. */
Tcl_HashSearch hSearch; /* For local searches. */
TclNewObj(listObjPtr);
hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_ListObjAppendElement(NULL, listObjPtr,
Tcl_NewStringObj((const char *)
Tcl_GetHashKey(hTblPtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3134 3135 3136 3137 3138 3139 3140 |
static int
ChildInvokeHidden(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command will
* be invoked. */
const char *namespaceName, /* The namespace to use, if any. */
| | | | 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 |
static int
ChildInvokeHidden(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command will
* be invoked. */
const char *namespaceName, /* The namespace to use, if any. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not allowed to invoke hidden commands from safe interpreter",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
(char *)NULL);
return TCL_ERROR;
}
Tcl_Preserve(childInterp);
Tcl_AllowExceptions(childInterp);
if (namespaceName == NULL) {
|
| ︙ | ︙ | |||
3182 3183 3184 3185 3186 3187 3188 |
static int
NRPostInvokeHidden(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 |
static int
NRPostInvokeHidden(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Interp *childInterp = (Tcl_Interp *) data[0];
NRE_callback *rootPtr = (NRE_callback *) data[1];
if (interp != childInterp) {
result = TclNRRunCallbacks(childInterp, result, rootPtr);
Tcl_TransferResult(childInterp, result, interp);
}
Tcl_Release(childInterp);
return result;
|
| ︙ | ︙ | |||
3221 3222 3223 3224 3225 3226 3227 |
* trusted. */
{
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot mark trusted",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
| | | 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 |
* trusted. */
{
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot mark trusted",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
(char *)NULL);
return TCL_ERROR;
}
((Interp *) childInterp)->flags &= ~SAFE_INTERP;
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3281 3282 3283 3284 3285 3286 3287 |
void
MakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
Interp *iPtr = (Interp *) interp;
| | | > | 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 |
void
MakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
Interp *iPtr = (Interp *) interp;
Tcl_Interp *parent = INTERP_INFO(iPtr)->child.parentInterp;
TclHideUnsafeCommands(interp);
if (parent != NULL) {
/*
* Alias these function implementations in the child to those in the
* parent; the overall implementations are safe, but they're normally
* defined by init.tcl which is not sourced by safe interpreters.
* Assume these functions all work. [Bug 2895741]
*/
(void) Tcl_EvalEx(interp,
"namespace eval ::tcl {namespace eval mathfunc {}}",
TCL_INDEX_NONE, 0);
}
iPtr->flags |= SAFE_INTERP;
/*
* Unsetting variables : (which should not have been set in the first
* place, but...)
|
| ︙ | ︙ | |||
3473 3474 3475 3476 3477 3478 3479 |
Tcl_Preserve(interp);
RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command count limit exceeded", -1));
| | | 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 |
Tcl_Preserve(interp);
RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command count limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", (char *)NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
Tcl_Release(interp);
}
if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
|
| ︙ | ︙ | |||
3499 3500 3501 3502 3503 3504 3505 |
if (iPtr->limit.time.sec > now.sec ||
(iPtr->limit.time.sec == now.sec &&
iPtr->limit.time.usec >= now.usec)) {
iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"time limit exceeded", -1));
| | | 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 |
if (iPtr->limit.time.sec > now.sec ||
(iPtr->limit.time.sec == now.sec &&
iPtr->limit.time.usec >= now.usec)) {
iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"time limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", (char *)NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
Tcl_Release(interp);
}
}
|
| ︙ | ︙ | |||
3619 3620 3621 3622 3623 3624 3625 |
deleteProc = TclpFree;
}
/*
* Allocate a handler record.
*/
| | | 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 |
deleteProc = TclpFree;
}
/*
* Allocate a handler record.
*/
handlerPtr = (LimitHandler *) Tcl_Alloc(sizeof(LimitHandler));
handlerPtr->flags = 0;
handlerPtr->handlerProc = handlerProc;
handlerPtr->clientData = clientData;
handlerPtr->deleteProc = deleteProc;
handlerPtr->prevPtr = NULL;
/*
|
| ︙ | ︙ | |||
4076 4077 4078 4079 4080 4081 4082 |
*----------------------------------------------------------------------
*/
static void
TimeLimitCallback(
void *clientData)
{
| | | | 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 |
*----------------------------------------------------------------------
*/
static void
TimeLimitCallback(
void *clientData)
{
Tcl_Interp *interp = (Tcl_Interp *) clientData;
Interp *iPtr = (Interp *) clientData;
int code;
Tcl_Preserve(interp);
iPtr->limit.timeEvent = NULL;
/*
* Must reset the granularity ticker here to force an immediate full
|
| ︙ | ︙ | |||
4220 4221 4222 4223 4224 4225 4226 |
*----------------------------------------------------------------------
*/
static void
DeleteScriptLimitCallback(
void *clientData)
{
| | | 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 |
*----------------------------------------------------------------------
*/
static void
DeleteScriptLimitCallback(
void *clientData)
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *) clientData;
Tcl_DecrRefCount(limitCBPtr->scriptObj);
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
Tcl_Free(limitCBPtr);
}
|
| ︙ | ︙ | |||
4252 4253 4254 4255 4256 4257 4258 |
*/
static void
CallScriptLimitCallback(
void *clientData,
TCL_UNUSED(Tcl_Interp *))
{
| | | 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 |
*/
static void
CallScriptLimitCallback(
void *clientData,
TCL_UNUSED(Tcl_Interp *))
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *) clientData;
int code;
if (Tcl_InterpDeleted(limitCBPtr->interp)) {
return;
}
Tcl_Preserve(limitCBPtr->interp);
code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj,
|
| ︙ | ︙ | |||
4320 4321 4322 4323 4324 4325 4326 |
}
return;
}
hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
&isNew);
if (!isNew) {
| | | > | 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 |
}
return;
}
hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
&isNew);
if (!isNew) {
limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hashPtr);
limitCBPtr->entryPtr = NULL;
Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
limitCBPtr);
}
limitCBPtr = (ScriptLimitCallback *)
Tcl_Alloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
limitCBPtr->type = type;
Tcl_IncrRefCount(scriptObj);
Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback,
|
| ︙ | ︙ | |||
4411 4412 4413 4414 4415 4416 4417 |
iPtr->limit.cmdHandlers = NULL;
iPtr->limit.cmdGranularity = 1;
memset(&iPtr->limit.time, 0, sizeof(Tcl_Time));
iPtr->limit.timeHandlers = NULL;
iPtr->limit.timeEvent = NULL;
iPtr->limit.timeGranularity = 10;
Tcl_InitHashTable(&iPtr->limit.callbacks,
| | | 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 |
iPtr->limit.cmdHandlers = NULL;
iPtr->limit.cmdGranularity = 1;
memset(&iPtr->limit.time, 0, sizeof(Tcl_Time));
iPtr->limit.timeHandlers = NULL;
iPtr->limit.timeEvent = NULL;
iPtr->limit.timeGranularity = 10;
Tcl_InitHashTable(&iPtr->limit.callbacks,
sizeof(ScriptLimitCallbackKey) / sizeof(int));
}
/*
*----------------------------------------------------------------------
*
* InheritLimitsFromParent --
*
|
| ︙ | ︙ | |||
4477 4478 4479 4480 4481 4482 4483 |
*----------------------------------------------------------------------
*/
static int
ChildCommandLimitCmd(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Interp *childInterp, /* Interpreter being adjusted. */
| | | | 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 |
*----------------------------------------------------------------------
*/
static int
ChildCommandLimitCmd(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Interp *childInterp, /* Interpreter being adjusted. */
Tcl_Size consumedObjc, /* Number of args already parsed. */
Tcl_Size objc, /* Total number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const options[] = {
"-command", "-granularity", "-value", NULL
};
enum Options {
OPT_CMD, OPT_GRAN, OPT_VAL
|
| ︙ | ︙ | |||
4502 4503 4504 4505 4506 4507 4508 |
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
| | > | < | | < | | < | | | < | | 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 |
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF",
(char *)NULL);
return TCL_ERROR;
}
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
TclDictPut(NULL, dictPtr, options[0], limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
}
} else {
Tcl_Obj *empty;
putEmptyCommandInDict:
TclNewObj(empty);
TclDictPut(NULL, dictPtr, options[0], empty);
}
TclDictPut(NULL, dictPtr, options[1], Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
TclDictPut(NULL, dictPtr, options[2], Tcl_NewWideIntObj(
Tcl_LimitGetCommands(childInterp)));
} else {
Tcl_Obj *empty;
TclNewObj(empty);
TclDictPut(NULL, dictPtr, options[2], empty);
}
Tcl_SetObjResult(interp, dictPtr);
return TCL_OK;
} else if (objc == consumedObjc+1) {
if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
|
| ︙ | ︙ | |||
4578 4579 4580 4581 4582 4583 4584 |
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
| < | | | | | | 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 |
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
Tcl_Size i, scriptLen = 0, limitLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
int gran = 0, limit = 0;
for (i=consumedObjc ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
(void) TclGetStringFromObj(scriptObj, &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", (char *)NULL);
return TCL_ERROR;
}
break;
case OPT_VAL:
limitObj = objv[i+1];
(void) TclGetStringFromObj(objv[i+1], &limitLen);
if (limitLen == 0) {
break;
}
if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command limit value must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", (char *)NULL);
return TCL_ERROR;
}
break;
}
}
if (scriptObj != NULL) {
SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, childInterp,
|
| ︙ | ︙ | |||
4663 4664 4665 4666 4667 4668 4669 | * Depends on the arguments. * *---------------------------------------------------------------------- */ static int ChildTimeLimitCmd( | | | | | | | 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 |
* Depends on the arguments.
*
*----------------------------------------------------------------------
*/
static int
ChildTimeLimitCmd(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Interp *childInterp, /* Interpreter being adjusted. */
Tcl_Size consumedObjc, /* Number of args already parsed. */
Tcl_Size objc, /* Total number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const options[] = {
"-command", "-granularity", "-milliseconds", "-seconds", NULL
};
enum Options {
OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC
} index;
|
| ︙ | ︙ | |||
4690 4691 4692 4693 4694 4695 4696 |
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
| | > | < | | < | | < | | | | < | < | | 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 |
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF",
(char *)NULL);
return TCL_ERROR;
}
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
TclDictPut(NULL, dictPtr, options[0], limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
}
} else {
Tcl_Obj *empty;
putEmptyCommandInDict:
TclNewObj(empty);
TclDictPut(NULL, dictPtr, options[0], empty);
}
TclDictPut(NULL, dictPtr, options[1], Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(childInterp, &limitMoment);
TclDictPut(NULL, dictPtr, options[2],
Tcl_NewWideIntObj(limitMoment.usec / 1000));
TclDictPut(NULL, dictPtr, options[3],
Tcl_NewWideIntObj(limitMoment.sec));
} else {
Tcl_Obj *empty;
TclNewObj(empty);
TclDictPut(NULL, dictPtr, options[2], empty);
TclDictPut(NULL, dictPtr, options[3], empty);
}
Tcl_SetObjResult(interp, dictPtr);
return TCL_OK;
} else if (objc == consumedObjc+1) {
if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
|
| ︙ | ︙ | |||
4783 4784 4785 4786 4787 4788 4789 |
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
| < | | | | | | | | | | | 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 |
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
Tcl_Size i, scriptLen = 0, milliLen = 0, secLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL;
Tcl_Obj *milliObj = NULL, *secObj = NULL;
int gran = 0;
Tcl_Time limitMoment;
Tcl_WideInt tmp;
Tcl_LimitGetTime(childInterp, &limitMoment);
for (i=consumedObjc ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
(void) TclGetStringFromObj(objv[i+1], &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", (char *)NULL);
return TCL_ERROR;
}
break;
case OPT_MILLI:
milliObj = objv[i+1];
(void) TclGetStringFromObj(objv[i+1], &milliLen);
if (milliLen == 0) {
break;
}
if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"milliseconds must be non-negative", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", (char *)NULL);
return TCL_ERROR;
}
limitMoment.usec = tmp*1000;
break;
case OPT_SEC:
secObj = objv[i+1];
(void) TclGetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"seconds must be non-negative", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", (char *)NULL);
return TCL_ERROR;
}
limitMoment.sec = (long long) tmp;
break;
}
}
if (milliObj != NULL || secObj != NULL) {
if (milliObj != NULL) {
/*
* Setting -milliseconds but clearing -seconds, or resetting
* -milliseconds but not resetting -seconds? Bad voodoo!
*/
if (secObj != NULL && secLen == 0 && milliLen > 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may only set -milliseconds if -seconds is not "
"also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", (char *)NULL);
return TCL_ERROR;
}
if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may only reset -milliseconds if -seconds is "
"also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", (char *)NULL);
return TCL_ERROR;
}
}
if (milliLen > 0 || secLen > 0) {
/*
* Force usec to be in range [0..1000000), possibly
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
| ︙ | ︙ | |||
105 106 107 108 109 110 111 | static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * A marker type used to flag weirdnesses so we can pass them around right. */ | | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
static int SetInvalidRealFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/*
* A marker type used to flag weirdnesses so we can pass them around right.
*/
static const Tcl_ObjType invalidRealType = {
"invalidReal", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V1(TclLengthOne)
};
/*
* Convenience macro for accessing the value of the C variable pointed to by a
* link. Note that this macro produces something that may be regarded as an
* lvalue or rvalue; it may be assigned to as well as read. Also note that
* this macro assumes the name of the variable being accessed (linkPtr); this
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 |
case TCL_LINK_STRING:
linkPtr->bytes = size * sizeof(char);
size = 1; /* This is a variable length string, no need
* to check last value. */
/*
* If no address is given create one and use as address the
| | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 |
case TCL_LINK_STRING:
linkPtr->bytes = size * sizeof(char);
size = 1; /* This is a variable length string, no need
* to check last value. */
/*
* If no address is given create one and use as address the
* not needed linkPtr->lastValue
*/
if (addr == NULL) {
linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_LAST;
addr = (char *) &linkPtr->lastValue.cPtr;
}
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
const char *str;
const char *endPtr;
Tcl_Size length;
| | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
const char *str;
const char *endPtr;
Tcl_Size length;
str = TclGetStringFromObj(objPtr, &length);
if ((length == 1) && (str[0] == '.')) {
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = 0.0;
return TCL_OK;
}
if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
static int
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
Tcl_Size length;
| | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
static int
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
Tcl_Size length;
const char *str = TclGetStringFromObj(objPtr, &length);
if ((length == 0) || ((length == 2) && (str[0] == '0')
&& strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
} else if ((length == 1) && strchr("+-", str[0])) {
*intPtr = (str[0] == '+');
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
/*
* Special cases.
*/
switch (linkPtr->type) {
case TCL_LINK_STRING:
| | | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 |
/*
* Special cases.
*/
switch (linkPtr->type) {
case TCL_LINK_STRING:
value = TclGetStringFromObj(valueObj, &valueLength);
pp = (char **) linkPtr->addr;
*pp = (char *)Tcl_Realloc(*pp, ++valueLength);
memcpy(*pp, value, valueLength);
return NULL;
case TCL_LINK_CHARS:
value = (char *) TclGetStringFromObj(valueObj, &valueLength);
valueLength++; /* include end of string char */
if (valueLength > linkPtr->bytes) {
return (char *) "wrong size of char* value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
memcpy(linkPtr->addr, value, valueLength);
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
((value) >= (lowerLimit) && (value) <= (upperLimit))
/*
* If we're working with an array of numbers, extract the Tcl list.
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
| | | | 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 |
((value) >= (lowerLimit) && (value) <= (upperLimit))
/*
* If we're working with an array of numbers, extract the Tcl list.
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
if (TclListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR
|| objc != linkPtr->numElems) {
return (char *) "wrong dimension";
}
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i = 0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (GetInt(objv[i], varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have integer values";
}
}
} else {
int *varPtr = &linkPtr->lastValue.i;
if (GetInt(valueObj, varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | | | | 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 |
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have boolean value";
}
}
} else {
int *varPtr = &linkPtr->lastValue.i;
if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have boolean value";
}
LinkedVar(int) = *varPtr;
}
break;
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have char value";
}
linkPtr->lastValue.cPtr[i] = (char) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have char value";
}
LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt;
}
break;
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(0, valueInt, (int)UCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned char value";
}
linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt;
}
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | | | 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 |
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have short value";
}
linkPtr->lastValue.sPtr[i] = (short) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have short value";
}
LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt;
}
break;
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(0, valueInt, (int)USHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned short value";
}
linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(0, valueInt, (int)USHRT_MAX)) {
|
| ︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 |
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetWide(objv[i], &valueWide)
|| !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 |
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetWide(objv[i], &valueWide)
|| !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned int value";
}
linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide;
}
} else {
if (GetWide(valueObj, &valueWide)
|| !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
|
| ︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 |
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);
| | | | | | 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 |
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 *)
"variable array must have unsigned wide int value";
}
linkPtr->lastValue.uwPtr[i] = valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned wide int value";
}
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide;
}
break;
case TCL_LINK_FLOAT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetDouble(objv[i], &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)"variable array must have float value";
}
linkPtr->lastValue.fPtr[i] = (float) valueDouble;
}
} else {
if (GetDouble(valueObj, &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)"variable must have float value";
}
LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble;
}
break;
default:
return (char *) "internal error: bad linked variable type";
|
| ︙ | ︙ |
Changes to generic/tclListObj.c.
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
SetListFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V1(ListLength)
};
/* Macros to manipulate the List internal rep */
| | | | | | > | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
SetListFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V1(ListLength)
};
/* Macros to manipulate the List internal rep */
#define ListRepIncrRefs(repPtr_) \
do { \
(repPtr_)->storePtr->refCount++; \
if ((repPtr_)->spanPtr) { \
(repPtr_)->spanPtr->refCount++; \
} \
} while (0)
/* Returns number of free unused slots at the back of the ListRep's ListStore */
#define ListRepNumFreeTail(repPtr_) \
((repPtr_)->storePtr->numAllocated \
- ((repPtr_)->storePtr->firstUsed + (repPtr_)->storePtr->numUsed))
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 | * * Side effects: * The memory may be freed. * *------------------------------------------------------------------------ */ static inline void | | > | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
*
* Side effects:
* The memory may be freed.
*
*------------------------------------------------------------------------
*/
static inline void
ListSpanDecrRefs(
ListSpan *spanPtr)
{
if (spanPtr->refCount <= 1) {
Tcl_Free(spanPtr);
} else {
spanPtr->refCount -= 1;
}
}
|
| ︙ | ︙ | |||
338 339 340 341 342 343 344 | * * Side effects: * See comments for ListRepUnsharedFreeUnreferenced. * *------------------------------------------------------------------------ */ static inline void | | > | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
*
* Side effects:
* See comments for ListRepUnsharedFreeUnreferenced.
*
*------------------------------------------------------------------------
*/
static inline void
ListRepFreeUnreferenced(
const ListRep *repPtr)
{
if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
/* T:listrep-1.5.1 */
ListRepUnsharedFreeUnreferenced(repPtr);
}
}
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
*/
static int
MemoryAllocationError(
Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
size_t size) /* Size of attempted allocation that failed */
{
if (interp != NULL) {
| | < < | | > | < | | | 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 |
*/
static int
MemoryAllocationError(
Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
size_t size) /* Size of attempted allocation that failed */
{
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list construction failed: unable to alloc %" TCL_Z_MODIFIER
"u bytes",
size));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return TCL_ERROR;
}
/*
*------------------------------------------------------------------------
*
* ListLimitExceeded --
*
* Generates an error for exceeding maximum list size.
*
* Results:
* Always TCL_ERROR.
*
* Side effects:
* Error message and code are stored in the interpreter if not NULL.
*
*------------------------------------------------------------------------
*/
static int
ListLimitExceededError(
Tcl_Interp *interp)
{
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"max length of a Tcl list exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return TCL_ERROR;
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 | * Side effects: * The contents of the ListRep's ListStore area are shifted down in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ static inline void | | > > | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
* Side effects:
* The contents of the ListRep's ListStore area are shifted down in the
* storage area. The ListRep's ListSpan is updated accordingly.
*
*------------------------------------------------------------------------
*/
static inline void
ListRepUnsharedShiftDown(
ListRep *repPtr,
Tcl_Size shiftCount)
{
ListStore *storePtr;
LISTREP_CHECK(repPtr);
LIST_ASSERT(!ListRepIsShared(repPtr));
storePtr = repPtr->storePtr;
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 | * The contents of the ListRep's ListStore area are shifted up in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ #if 0 static inline void | | > > | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
* The contents of the ListRep's ListStore area are shifted up in the
* storage area. The ListRep's ListSpan is updated accordingly.
*
*------------------------------------------------------------------------
*/
#if 0
static inline void
ListRepUnsharedShiftUp(
ListRep *repPtr,
Tcl_Size shiftCount)
{
ListStore *storePtr;
LISTREP_CHECK(repPtr);
LIST_ASSERT(!ListRepIsShared(repPtr));
LIST_COUNT_ASSERT(shiftCount);
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 | * * Side effects: * Panics if any invariant is not met. * *------------------------------------------------------------------------ */ static void | | > > > | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
*
* Side effects:
* Panics if any invariant is not met.
*
*------------------------------------------------------------------------
*/
static void
ListRepValidate(
const ListRep *repPtr,
const char *file,
int lineNum)
{
ListStore *storePtr = repPtr->storePtr;
const char *condition;
(void)storePtr; /* To stop gcc from whining about unused vars */
#define INVARIANT(cond_) \
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 | * Side effects: * Will panic if internal structure is not consistent or if object * cannot be converted to a list object. * *------------------------------------------------------------------------ */ void | | > > | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
* Side effects:
* Will panic if internal structure is not consistent or if object
* cannot be converted to a list object.
*
*------------------------------------------------------------------------
*/
void
TclListObjValidate(
Tcl_Interp *interp,
Tcl_Obj *listObj)
{
ListRep listRep;
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
Tcl_Panic("Object passed to TclListObjValidate cannot be converted to "
"a list object.");
}
ListRepValidate(&listRep, __FILE__, __LINE__);
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 | * Side effects: * The memory pointed to by storePtr is freed if it a new block has to * be returned. * * *------------------------------------------------------------------------ */ | | | > > | < < | < | 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 |
* Side effects:
* The memory pointed to by storePtr is freed if it a new block has to
* be returned.
*
*
*------------------------------------------------------------------------
*/
static ListStore *
ListStoreReallocate(
ListStore *storePtr,
Tcl_Size needed)
{
Tcl_Size capacity;
if (needed > LIST_MAX) {
return NULL;
}
storePtr = (ListStore *) TclAttemptReallocElemsEx(storePtr,
needed, sizeof(Tcl_Obj *), offsetof(ListStore, slots), &capacity);
/* Only the capacity has changed, fix it in the header */
if (storePtr) {
storePtr->numAllocated = capacity;
}
return storePtr;
}
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
*----------------------------------------------------------------------
*/
static int
ListRepInit(
Tcl_Size objc,
Tcl_Obj *const objv[],
int flags,
| | < | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 |
*----------------------------------------------------------------------
*/
static int
ListRepInit(
Tcl_Size objc,
Tcl_Obj *const objv[],
int flags,
ListRep *repPtr)
{
ListStore *storePtr;
storePtr = ListStoreNew(objc, objv, flags);
if (storePtr) {
repPtr->storePtr = storePtr;
if (storePtr->firstUsed == 0) {
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 | * The toRepPtr location is initialized with the ListStore and ListSpan * (if needed) containing a copy of the list elements in fromRepPtr. * The function will panic if memory cannot be allocated. * *------------------------------------------------------------------------ */ static void | | > > > | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
* The toRepPtr location is initialized with the ListStore and ListSpan
* (if needed) containing a copy of the list elements in fromRepPtr.
* The function will panic if memory cannot be allocated.
*
*------------------------------------------------------------------------
*/
static void
ListRepClone(
ListRep *fromRepPtr,
ListRep *toRepPtr,
int flags)
{
Tcl_Obj **fromObjs;
Tcl_Size numFrom;
ListRepElements(fromRepPtr, numFrom, fromObjs);
ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr);
}
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 | * * Side effects: * The firstUsed and numUsed fields of the ListStore are updated to * reflect the new "in-use" extent. * *------------------------------------------------------------------------ */ | > | > | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 |
*
* Side effects:
* The firstUsed and numUsed fields of the ListStore are updated to
* reflect the new "in-use" extent.
*
*------------------------------------------------------------------------
*/
static void
ListRepUnsharedFreeUnreferenced(
const ListRep *repPtr)
{
Tcl_Size count;
ListStore *storePtr;
ListSpan *spanPtr;
LIST_ASSERT(!ListRepIsShared(repPtr));
LISTREP_CHECK(repPtr);
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 |
*------------------------------------------------------------------------
*/
Tcl_Obj *
TclNewListObj2(
Tcl_Size objc1, /* Count of objects referenced by objv1. */
Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */
Tcl_Size objc2, /* Count of objects referenced by objv2. */
| | < | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 |
*------------------------------------------------------------------------
*/
Tcl_Obj *
TclNewListObj2(
Tcl_Size objc1, /* Count of objects referenced by objv1. */
Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */
Tcl_Size objc2, /* Count of objects referenced by objv2. */
Tcl_Obj *const objv2[]) /* Second array of pointers to Tcl objects. */
{
Tcl_Obj *listObj;
ListStore *storePtr;
Tcl_Size objc = objc1 + objc2;
listObj = Tcl_NewListObj(objc, NULL);
if (objc == 0) {
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 |
*/
static int
TclListObjGetRep(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object for which an element array is
* to be returned. */
| | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
*/
static int
TclListObjGetRep(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object for which an element array is
* to be returned. */
ListRep *repPtr) /* Location to store descriptor */
{
if (!TclHasInternalRep(listObj, &tclListType)) {
int result;
result = SetListFromAny(interp, listObj);
if (result != TCL_OK) {
/* Init to keep gcc happy wrt uninitialized fields at call site */
repPtr->storePtr = NULL;
|
| ︙ | ︙ | |||
1385 1386 1387 1388 1389 1390 1391 | * to get wrong. Mostly due to refcount combinations. Perhaps passing * in the source listObj instead of source listRep might simplify. * *------------------------------------------------------------------------ */ static void ListRepRange( | | | | | | | | | 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 |
* to get wrong. Mostly due to refcount combinations. Perhaps passing
* in the source listObj instead of source listRep might simplify.
*
*------------------------------------------------------------------------
*/
static void
ListRepRange(
ListRep *srcRepPtr, /* Contains source of the range */
Tcl_Size rangeStart, /* Index of first element to include */
Tcl_Size rangeEnd, /* Index of last element to include */
int preserveSrcRep, /* If true, srcRepPtr contents must not be
* modified (generally because a shared Tcl_Obj
* references it) */
ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */
{
Tcl_Obj **srcElems;
Tcl_Size numSrcElems = ListRepLength(srcRepPtr);
Tcl_Size rangeLen;
Tcl_Size numAfterRangeEnd;
LISTREP_CHECK(srcRepPtr);
|
| ︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 |
* be returned as is even if the range encompasses the whole list.
*/
if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
/* Option 0 - entire list. This may be used to canonicalize */
/* T:listrep-1.10.1,2.8.1 */
*rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */
} else if (rangeStart == 0 && (!preserveSrcRep)
| | | < | | | 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 |
* be returned as is even if the range encompasses the whole list.
*/
if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
/* Option 0 - entire list. This may be used to canonicalize */
/* T:listrep-1.10.1,2.8.1 */
*rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */
} else if (rangeStart == 0 && (!preserveSrcRep)
&& (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) {
/* Option 1 - Special case unshared, exclude end elements, no span */
LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
/* Assert: Because numSrcElems > rangeEnd earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-1.{8,9} */
ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
}
/* srcRepPtr->storePtr->firstUsed,numAllocated unchanged */
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */
rangeRepPtr->spanPtr = NULL;
} else if (ListSpanMerited(rangeLen, srcRepPtr->storePtr->numUsed,
srcRepPtr->storePtr->numAllocated)) {
/* Option 2 - because span would be most efficient */
Tcl_Size spanStart = ListRepStart(srcRepPtr) + rangeStart;
if (!preserveSrcRep && srcRepPtr->spanPtr
&& srcRepPtr->spanPtr->refCount <= 1) {
/* If span is not shared reuse it */
/* T:listrep-2.7.3,3.{16,18} */
srcRepPtr->spanPtr->spanStart = spanStart;
srcRepPtr->spanPtr->spanLength = rangeLen;
*rangeRepPtr = *srcRepPtr;
} else {
/* Span not present or is shared. */
|
| ︙ | ︙ | |||
1491 1492 1493 1494 1495 1496 1497 |
ListRepFreeUnreferenced(rangeRepPtr);
}
} else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
/* Option 3 - span or modification in place not allowed/desired */
/* T:listrep-2.{4,6} */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* TODO - allocate extra space? */
| | < < | | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 |
ListRepFreeUnreferenced(rangeRepPtr);
}
} else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
/* Option 3 - span or modification in place not allowed/desired */
/* T:listrep-2.{4,6} */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* TODO - allocate extra space? */
ListRepInit(rangeLen, &srcElems[rangeStart], LISTREP_PANIC_ON_FAIL,
rangeRepPtr);
} else {
/*
* Option 4 - modify in place. Note that because of the invariant
* that spanless list stores must start at 0, we have to move
* everything to the front.
* TODO - perhaps if a span already exists, no need to move to front?
* or maybe no need to move all the way to the front?
|
| ︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 |
Tcl_Size rangeStart, /* Index of first element to include. */
Tcl_Size rangeEnd) /* Index of last element to include. */
{
ListRep listRep;
ListRep resultRep;
int isShared;
| | > | | | < | 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 |
Tcl_Size rangeStart, /* Index of first element to include. */
Tcl_Size rangeEnd) /* Index of last element to include. */
{
ListRep listRep;
ListRep resultRep;
int isShared;
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
return NULL;
}
isShared = Tcl_IsShared(listObj);
ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep);
if (isShared) {
/* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
TclNewObj(listObj);
} /* T:listrep-1.{4.3,5.1,5.2} */
ListObjReplaceRepAndInvalidate(listObj, &resultRep);
return listObj;
}
/*
*----------------------------------------------------------------------
*
* TclListObjGetElement --
*
* Returns a single element from the array of the elements in a list
* object, without doing any bounds checking. Caller must ensure
* that ObjPtr of type 'tclListType' and that index is valid for the
* list.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjGetElement(
Tcl_Obj *objPtr, /* List object for which an element array is
* to be returned. */
Tcl_Size index)
{
return ListObjStorePtr(objPtr)->slots[ListObjStart(objPtr) + index];
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 |
{
ListRep listRep;
if (TclObjTypeHasProc(objPtr, getElementsProc)) {
return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr);
}
if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) {
| | | 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 |
{
ListRep listRep;
if (TclObjTypeHasProc(objPtr, getElementsProc)) {
return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr);
}
if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) {
return TCL_ERROR;
}
ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1707 1708 1709 1710 1711 1712 1713 |
Tcl_Size objc;
Tcl_Obj **objv;
if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
| | | | > | | | | > | > | > > > > > > > > > > | > > | 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 |
Tcl_Size objc;
Tcl_Obj **objv;
if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
if (TclListObjGetElements(interp, fromObj, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Insert the new elements starting after the lists's last element.
* Delete zero existing elements.
*/
return TclListObjAppendElements(interp, toObj, objc, objv);
}
/*
*------------------------------------------------------------------------
*
* TclListObjAppendElements --
*
* Appends multiple elements to a Tcl_Obj list object. If
* the passed Tcl_Obj is not a list object, it will be converted to one
* and an error raised if the conversion fails.
*
* The Tcl_Obj must not be shared though the internal representation
* may be.
*
* Results:
* On success, TCL_OK is returned with the specified elements appended.
* On failure, TCL_ERROR is returned with an error message in the
* interpreter if not NULL.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
int
TclListObjAppendElements (
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *toObj, /* List object to append */
Tcl_Size elemCount, /* Number of elements in elemObjs[] */
Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */
{
ListRep listRep;
Tcl_Obj **toObjv;
Tcl_Size toLen;
Tcl_Size finalLen;
if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "TclListObjAppendElements");
}
if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK) {
/* Cannot be converted to a list */
return TCL_ERROR;
}
if (elemCount <= 0) {
/*
* Note that when elemCount <= 0, this routine is logically a
* no-op, removing and adding no elements to the list. However, by removing
* the string representation, we get the important side effect that the
* resulting listPtr is a list in canonical form. This is important.
* Resist any temptation to optimize this case further. See bug [e38dce74e2].
*/
if (!ListObjIsCanonical(toObj)) {
TclInvalidateStringRep(toObj);
}
/* Nothing to do. Note AFTER check for list above */
return TCL_OK;
}
ListRepElements(&listRep, toLen, toObjv);
if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) {
return ListLimitExceededError(interp);
}
finalLen = toLen + elemCount;
|
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 |
LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed);
LIST_ASSERT(toLen == listRep.storePtr->numUsed);
if (finalLen > listRep.storePtr->numAllocated) {
/* T:listrep-1.{2,11},3.6 */
| | | | 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 |
LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed);
LIST_ASSERT(toLen == listRep.storePtr->numUsed);
if (finalLen > listRep.storePtr->numAllocated) {
/* T:listrep-1.{2,11},3.6 */
ListStore *newStorePtr = ListStoreReallocate(
listRep.storePtr, finalLen);
if (newStorePtr == NULL) {
return MemoryAllocationError(interp, LIST_SIZE(finalLen));
}
LIST_ASSERT(newStorePtr->numAllocated >= finalLen);
listRep.storePtr = newStorePtr;
/*
* WARNING: at this point the Tcl_Obj internal rep potentially
|
| ︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 |
shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2;
LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed);
if (shiftCount) {
/* T:listrep-3.5 */
ListRepUnsharedShiftDown(&listRep, shiftCount);
}
} /* else T:listrep-3.{4,6} */
| > | | | < | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 |
shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2;
LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed);
if (shiftCount) {
/* T:listrep-3.5 */
ListRepUnsharedShiftDown(&listRep, shiftCount);
}
} /* else T:listrep-3.{4,6} */
ObjArrayCopy(
&listRep.storePtr->slots[
ListRepStart(&listRep) + ListRepLength(&listRep)],
elemCount, elemObjv);
listRep.storePtr->numUsed = finalLen;
if (listRep.spanPtr) {
/* T:listrep-3.{4,5,6} */
LIST_ASSERT(listRep.spanPtr->spanStart
== listRep.storePtr->firstUsed);
listRep.spanPtr->spanLength = finalLen;
} /* else T:listrep-3.6.3 */
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 |
/*
* Have to make a new list rep, either shared or no room in old one.
* If the old list did not have a span (all elements at front), do
* not leave space in the front either, assuming all appends and no
* prepends.
*/
| | < | < | < | 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 |
/*
* Have to make a new list rep, either shared or no room in old one.
* If the old list did not have a span (all elements at front), do
* not leave space in the front either, assuming all appends and no
* prepends.
*/
if (ListRepInit(finalLen, NULL,
listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK : LISTREP_SPACE_ONLY_BACK,
&listRep) != TCL_OK) {
return MemoryAllocationError(interp, finalLen);
}
LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
if (toLen) {
/* T:listrep-2.{2,9},4.5 */
ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv);
|
| ︙ | ︙ | |||
1914 1915 1916 1917 1918 1919 1920 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * | | | | < | < | < | | | < | | | | | | < | 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 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjIndex --
*
* Retrieve a pointer to the element of 'listPtr' at 'index'. The index
* of the first element is 0.
*
* Returns:
* TCL_OK
* A pointer to the element at 'index' is stored in 'objPtrPtr'. If
* 'index' is out of range, NULL is stored in 'objPtrPtr'. This
* object should be treated as readonly and its 'refCount' is _not_
* incremented. The caller must do that if it holds on to the
* reference.
*
* TCL_ERROR
* 'listPtr' is not a valid list. An error message is left in the
* interpreter's result if 'interp' is not NULL.
*
* Effect:
* If 'listPtr' is not already of type 'tclListType', it is converted.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjIndex(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object to index into. */
Tcl_Size index, /* Index of element to return. */
Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
{
Tcl_Obj **elemObjs;
Tcl_Size numElems;
/* Empty string => empty list. Avoid unnecessary shimmering */
if (listObj->bytes == &tclEmptyString) {
*objPtrPtr = NULL;
return TCL_OK;
}
int hasAbstractList = TclObjTypeHasProc(listObj,indexProc) != 0;
if (hasAbstractList) {
return TclObjTypeIndex(interp, listObj, index, objPtrPtr);
}
if (TclListObjGetElements(interp, listObj, &numElems, &elemObjs) != TCL_OK) {
return TCL_ERROR;
}
if ((index < 0) || (index >= numElems)) {
*objPtrPtr = NULL;
} else {
*objPtrPtr = elemObjs[index];
}
|
| ︙ | ︙ | |||
2014 2015 2016 2017 2018 2019 2020 |
}
if (TclObjTypeHasProc(listObj, lengthProc)) {
*lenPtr = TclObjTypeLength(listObj);
return TCL_OK;
}
| < | | > | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 |
}
if (TclObjTypeHasProc(listObj, lengthProc)) {
*lenPtr = TclObjTypeLength(listObj);
return TCL_OK;
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
return TCL_ERROR;
}
*lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
static Tcl_Size
ListLength(
Tcl_Obj *listPtr)
{
ListRep listRep;
ListObjGetRep(listPtr, &listRep);
return ListRepLength(&listRep);
}
|
| ︙ | ︙ | |||
2094 2095 2096 2097 2098 2099 2100 |
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (TclObjTypeHasProc(listObj, replaceProc)) {
return TclObjTypeReplace(interp, listObj, first,
| | | | > > | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 |
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (TclObjTypeHasProc(listObj, replaceProc)) {
return TclObjTypeReplace(interp, listObj, first,
numToDelete, numToInsert, insertObjs);
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
/* Cannot be converted to a list */
return TCL_ERROR;
}
/* Make limits sane */
origListLen = ListRepLength(&listRep);
if (first < 0) {
first = 0;
}
if (first > origListLen) {
|
| ︙ | ︙ | |||
2200 2201 2202 2203 2204 2205 2206 | * Case (2b) - pure inserts at front under some circumstances * (i) Insertion must be at head of list * (ii) The list's span must be at head of the in-use slots in the store * (iii) There must be unused room at front of the store * NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not * affect the other Tcl_Obj's referencing this ListStore. */ | | | | < | < | 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 |
* Case (2b) - pure inserts at front under some circumstances
* (i) Insertion must be at head of list
* (ii) The list's span must be at head of the in-use slots in the store
* (iii) There must be unused room at front of the store
* NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not
* affect the other Tcl_Obj's referencing this ListStore.
*/
if (first == 0 && /* (i) */
ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */
numToInsert <= listRep.storePtr->firstUsed) { /* (iii) */
Tcl_Size newLen;
LIST_ASSERT(numToInsert); /* Else would have returned above */
listRep.storePtr->firstUsed -= numToInsert;
ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed],
numToInsert, insertObjs);
listRep.storePtr->numUsed += numToInsert;
newLen = listRep.spanPtr->spanLength + numToInsert;
if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
/* An unshared span record, re-use it */
/* T:listrep-3.1 */
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = newLen;
|
| ︙ | ︙ | |||
2254 2255 2256 2257 2258 2259 2260 |
*/
if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) {
/* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14,27,32,41} */
ListStore *newStorePtr =
ListStoreReallocate(listRep.storePtr, origListLen + lenChange);
if (newStorePtr == NULL) {
return MemoryAllocationError(interp,
| | | | | | | < | < | < | < | | 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 |
*/
if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) {
/* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14,27,32,41} */
ListStore *newStorePtr =
ListStoreReallocate(listRep.storePtr, origListLen + lenChange);
if (newStorePtr == NULL) {
return MemoryAllocationError(interp,
LIST_SIZE(origListLen + lenChange));
}
listRep.storePtr = newStorePtr;
numFreeSlots =
listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
/*
* WARNING: at this point the Tcl_Obj internal rep potentially
* points to freed storage if the reallocation returned a
* different location. Overwrite it to bring it back in sync.
*/
ListObjStompRep(listObj, &listRep);
}
/*
* Case (3) a new ListStore is required
* (a) The passed-in ListStore is shared
* (b) There is not enough free space in the unshared passed-in ListStore
* (c) The new unshared size is much "smaller" (TODO) than the allocated space
* TODO - for unshared case ONLY, consider a "move" based implementation
*/
if (ListRepIsShared(&listRep) || /* 3a */
numFreeSlots < lenChange || /* 3b */
(origListLen + lenChange) <
(listRep.storePtr->numAllocated / 4)) { /* 3c */
ListRep newRep;
Tcl_Obj **toObjs;
listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
ListRepInit(origListLen + lenChange, NULL,
LISTREP_PANIC_ON_FAIL | favor, &newRep);
toObjs = ListRepSlotPtr(&newRep, 0);
if (leadSegmentLen > 0) {
/* T:listrep-2.{2,3,13:18},4.{6,9,13:18} */
ObjArrayCopy(toObjs, leadSegmentLen, listObjs);
}
if (numToInsert > 0) {
/* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,10:18} */
ObjArrayCopy(&toObjs[leadSegmentLen], numToInsert,
insertObjs);
}
if (tailSegmentLen > 0) {
/* T:listrep-2.{1,2,3,10:15},4.{1,2,4,6,9:12,16:18} */
ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert],
tailSegmentLen, &listObjs[leadSegmentLen+numToDelete]);
}
newRep.storePtr->numUsed = origListLen + lenChange;
if (newRep.spanPtr) {
/* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,9:18} */
newRep.spanPtr->spanLength = newRep.storePtr->numUsed;
}
LISTREP_CHECK(&newRep);
|
| ︙ | ︙ | |||
2396 2397 2398 2399 2400 2401 2402 | */ Tcl_Size leadSpace = ListRepNumFreeHead(&listRep); Tcl_Size tailSpace = ListRepNumFreeTail(&listRep); Tcl_Size finalFreeSpace = leadSpace + tailSpace - lenChange; LIST_ASSERT((leadSpace + tailSpace) >= lenChange); if (leadSpace >= lenChange | | | 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 |
*/
Tcl_Size leadSpace = ListRepNumFreeHead(&listRep);
Tcl_Size tailSpace = ListRepNumFreeTail(&listRep);
Tcl_Size finalFreeSpace = leadSpace + tailSpace - lenChange;
LIST_ASSERT((leadSpace + tailSpace) >= lenChange);
if (leadSpace >= lenChange
&& (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) {
/* Move only lead to the front to make more room */
/* T:listrep-3.25,36,38, */
leadShift = -lenChange;
tailShift = 0;
/*
* Redistribute the remaining free space between the front and
* back if either there is no tail space left or if the
|
| ︙ | ︙ | |||
2525 2526 2527 2528 2529 2530 2531 |
/* Need a new span record */
if (listRep.storePtr->firstUsed == 0) {
/* T:listrep-1.{7,12,15,17,19,20} */
listRep.spanPtr = NULL;
} else {
/* T:listrep-1.{1,3,6.1,13,14,16,18,21} */
listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed,
| | | 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 |
/* Need a new span record */
if (listRep.storePtr->firstUsed == 0) {
/* T:listrep-1.{7,12,15,17,19,20} */
listRep.spanPtr = NULL;
} else {
/* T:listrep-1.{1,3,6.1,13,14,16,18,21} */
listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed,
listRep.storePtr->numUsed);
}
}
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 |
*/
Tcl_Obj *
TclLindexList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* List being unpacked. */
Tcl_Obj *argObj) /* Index or index list. */
{
| | | | | 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 |
*/
Tcl_Obj *
TclLindexList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* List being unpacked. */
Tcl_Obj *argObj) /* Index or index list. */
{
Tcl_Size index; /* Index into the list. */
Tcl_Obj *indexListCopy;
Tcl_Obj **indexObjs;
Tcl_Size numIndexObjs;
/*
* Determine whether argPtr designates a list or a single index. We have
* to be careful about the order of the checks to avoid repeated
* shimmering; if internal rep is already a list do not shimmer it.
* see TIP#22 and TIP#33 for the details.
*/
if (!TclHasInternalRep(argObj, &tclListType)
&& TclGetIntForIndexM(NULL, argObj, TCL_SIZE_MAX - 1,
&index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
/*
|
| ︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 |
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
* TODO - This is as original code. why not directly return an error?
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
| | | 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 |
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
* TODO - This is as original code. why not directly return an error?
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
TclListObjGetElements(interp, indexListCopy, &numIndexObjs, &indexObjs);
listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
return listObj;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2651 2652 2653 2654 2655 2656 2657 |
int status;
Tcl_Size i;
/* Handle AbstractList as special case */
if (TclObjTypeHasProc(listObj,indexProc)) {
Tcl_Size listLen = TclObjTypeLength(listObj);
Tcl_Size index;
| | | > | 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 |
int status;
Tcl_Size i;
/* Handle AbstractList as special case */
if (TclObjTypeHasProc(listObj,indexProc)) {
Tcl_Size listLen = TclObjTypeLength(listObj);
Tcl_Size index;
Tcl_Obj *elemObj = listObj; /* for lindex without indices return list */
for (i=0 ; i<indexCount && listObj ; i++) {
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
// TODO: ???
}
if (i==0) {
if (TclObjTypeIndex(interp, listObj, index, &elemObj) != TCL_OK) {
return NULL;
}
} else if (index > 0) {
// TODO: support nested lists
|
| ︙ | ︙ | |||
2692 2693 2694 2695 2696 2697 2698 |
if (index < 0 || index >= listLen) {
/*
* Index is out of range. Break out of loop with empty result.
* First check remaining indices for validity
*/
while (++i < indexCount) {
| | | < | 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 |
if (index < 0 || index >= listLen) {
/*
* Index is out of range. Break out of loop with empty result.
* First check remaining indices for validity
*/
while (++i < indexCount) {
if (TclGetIntForIndexM(interp, indexArray[i],
TCL_SIZE_MAX - 1, &index) != TCL_OK) {
Tcl_DecrRefCount(listObj);
return NULL;
}
}
Tcl_DecrRefCount(listObj);
TclNewObj(listObj);
Tcl_IncrRefCount(listObj);
|
| ︙ | ︙ | |||
2783 2784 2785 2786 2787 2788 2789 |
* We have to be careful about the order of the checks to avoid repeated
* shimmering; see TIP #22 and #23 for details.
*/
if (!TclHasInternalRep(indexArgObj, &tclListType)
&& TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index)
== TCL_OK) {
| < | | | > > | | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 |
* We have to be careful about the order of the checks to avoid repeated
* shimmering; see TIP #22 and #23 for details.
*/
if (!TclHasInternalRep(indexArgObj, &tclListType)
&& TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index)
== TCL_OK) {
if (TclObjTypeHasProc(listObj, setElementProc)) {
indices = &indexArgObj;
retValueObj = TclObjTypeSetElement(
interp, listObj, 1, indices, valueObj);
if (retValueObj) {
Tcl_IncrRefCount(retValueObj);
}
} else {
/* indexArgPtr designates a single index. */
/* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
} else {
indexListCopy = TclListObjCopy(NULL,indexArgObj);
if (!indexListCopy) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
} else {
if (TCL_OK != TclListObjGetElements(
interp, indexListCopy, &indexCount, &indices)) {
Tcl_DecrRefCount(indexListCopy);
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
|
| ︙ | ︙ | |||
2870 2871 2872 2873 2874 2875 2876 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* Pointer to the list being modified. */
| | | 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* Pointer to the list being modified. */
Tcl_Size indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
Tcl_Size index, len;
int result;
Tcl_Obj *subListObj, *retValueObj;
|
| ︙ | ︙ | |||
2917 2918 2919 2920 2921 2922 2923 |
* invalidated if the operation succeeds.
*/
retValueObj = subListObj;
result = TCL_OK;
/* Allocate if static array for pending invalidations is too small */
| | | | | | | | | | | | | | < | | < < < < < | 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 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 |
* invalidated if the operation succeeds.
*/
retValueObj = subListObj;
result = TCL_OK;
/* Allocate if static array for pending invalidations is too small */
if (indexCount > (Tcl_Size) (sizeof(pendingInvalidates) /
sizeof(pendingInvalidates[0]))) {
pendingInvalidatesPtr =
(Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr));
}
/*
* Loop through all the index arguments, and for each one dive into the
* appropriate sublist.
*/
do {
Tcl_Size elemCount;
Tcl_Obj *parentList, **elemPtrs;
/*
* Check for the possible error conditions...
*/
if (TclListObjGetElements(interp, subListObj,
&elemCount, &elemPtrs) != TCL_OK) {
/* ...the sublist we're indexing into isn't a list at all. */
result = TCL_ERROR;
break;
}
/*
* WARNING: the macro TclGetIntForIndexM is not safe for
* post-increments, avoid '*indexArray++' here.
*/
if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1,
&index) != TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
result = TCL_ERROR;
indexArray++; /* Why bother with this increment? TBD */
break;
}
indexArray++;
/*
* Special case 0-length lists. The Tcl indexing function treat
* will return any value beyond length as TCL_SIZE_MAX for this
* case.
*/
if ((index == TCL_SIZE_MAX) && (elemCount == 0)) {
index = 0;
}
if (index < 0 || index > elemCount
|| (valueObj == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range", TclGetString(indexArray[-1])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (char *)NULL);
}
result = TCL_ERROR;
break;
}
/*
* No error conditions. As long as we're not yet on the last index,
|
| ︙ | ︙ | |||
3030 3031 3032 3033 3034 3035 3036 | * so far is replace a list element with an unshared copy. The * list value remains the same, so the string rep. is still * valid, and unchanged, which is good because if this whole * routine returns NULL, we'd like to leave no change to the * value of the lset variable. Later on, when we set valueObj * in its proper place, then all containing lists will have * their values changed, and will need their string reps | | | < | 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 |
* so far is replace a list element with an unshared copy. The
* list value remains the same, so the string rep. is still
* valid, and unchanged, which is good because if this whole
* routine returns NULL, we'd like to leave no change to the
* value of the lset variable. Later on, when we set valueObj
* in its proper place, then all containing lists will have
* their values changed, and will need their string reps
* spoiled. We maintain a list of all those Tcl_Obj's
* pendingInvalidatesPtr[] so we can spoil them at that time.
*/
pendingInvalidatesPtr[numPendingInvalidates] = parentList;
++numPendingInvalidates;
}
} while (indexCount > 0);
|
| ︙ | ︙ | |||
3072 3073 3074 3075 3076 3077 3078 |
ListRep objInternalRep;
TclListObjGetRep(NULL, objPtr, &objInternalRep);
ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep);
}
}
}
| | > | | 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 |
ListRep objInternalRep;
TclListObjGetRep(NULL, objPtr, &objInternalRep);
ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep);
}
}
}
if (pendingInvalidatesPtr != pendingInvalidates) {
Tcl_Free(pendingInvalidatesPtr);
}
if (result != TCL_OK) {
/*
* Error return; message is already in interp. Clean up any excess
* memory.
*/
if (retValueObj != listObj) {
Tcl_DecrRefCount(retValueObj);
}
return NULL;
}
/*
* Store valueObj in proper sublist and return. The -1 is to avoid a
* compiler warning (not a problem because we checked that we have a
* proper list - or something convertible to one - above).
*/
len = -1;
TclListObjLength(NULL, subListObj, &len);
if (valueObj == NULL) {
/* T:listrep-1.{4.2,5.4,6.1,7.1,8.3},2.{4,5}.4 */
Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL);
} else if (index == len) {
/* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */
Tcl_ListObjAppendElement(NULL, subListObj, valueObj);
} else {
|
| ︙ | ︙ | |||
3166 3167 3168 3169 3170 3171 3172 |
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));
| | < | 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 |
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", (char *)NULL);
}
return TCL_ERROR;
}
/*
* Note - garbage collect this only AFTER checking indices above.
* Do not want to modify listrep and then not store it back in listObj.
|
| ︙ | ︙ | |||
3316 3317 3318 3319 3320 3321 3322 | * note that since we know we've got a valid dictionary (by * representation) we also know that fetching the size of the * dictionary or iterating over it will not fail. */ Tcl_DictObjSize(NULL, objPtr, &size); /* TODO - leave space in front and/or back? */ | | < | | 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 |
* note that since we know we've got a valid dictionary (by
* representation) we also know that fetching the size of the
* dictionary or iterating over it will not fail.
*/
Tcl_DictObjSize(NULL, objPtr, &size);
/* TODO - leave space in front and/or back? */
if (ListRepInitAttempt(interp, size > 0 ? 2 * size : 1, NULL,
&listRep) != TCL_OK) {
return TCL_ERROR;
}
LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
LIST_ASSERT(listRep.storePtr->firstUsed == 0);
LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0);
|
| ︙ | ︙ | |||
3367 3368 3369 3370 3371 3372 3373 |
LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount);
listRep.storePtr->numUsed = elemCount;
} else {
Tcl_Size estCount, length;
| | | < | | 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 |
LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount);
listRep.storePtr->numUsed = elemCount;
} else {
Tcl_Size estCount, length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
* (possible) list element.
*/
estCount = TclMaxListLength(nextElem, length, &limit);
estCount += (estCount == 0); /* Smallest list struct holds 1
* element. */
/* TODO - allocate additional space? */
if (ListRepInitAttempt(interp, estCount, NULL, &listRep) != TCL_OK) {
return TCL_ERROR;
}
LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
LIST_ASSERT(listRep.storePtr->firstUsed == 0);
elemPtrs = listRep.storePtr->slots;
/* Each iteration, parse and store a list element. */
while (nextElem < limit) {
const char *elemStart;
char *check;
Tcl_Size elemSize;
int literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
fail:
while (--elemPtrs >= listRep.storePtr->slots) {
Tcl_DecrRefCount(*elemPtrs);
}
Tcl_Free(listRep.storePtr);
return TCL_ERROR;
}
if (elemStart == limit) {
|
| ︙ | ︙ | |||
3527 3528 3529 3530 3531 3532 3533 |
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (char *)Tcl_Alloc(numElems);
}
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
| | | < | > > > | 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 |
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (char *)Tcl_Alloc(numElems);
}
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded > SIZE_MAX - numElems) {
Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX);
}
}
bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded);
TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
/* Set the string length to what was actually written, the safe choice */
(void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
Tcl_Free(flagPtr);
}
}
/*
*------------------------------------------------------------------------
*
* TclListTestObj --
*
* Returns a list object with a specific internal rep and content.
* Used specifically for testing so span can be controlled explicitly.
*
* Results:
* Pointer to the Tcl_Obj containing the list.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
Tcl_Obj *
TclListTestObj(
size_t length,
size_t leadingSpace,
size_t endSpace)
{
ListRep listRep;
size_t capacity;
Tcl_Obj *listObj;
TclNewObj(listObj);
|
| ︙ | ︙ |
Changes to generic/tclLiteral.c.
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
Tcl_Size length, /* Number of bytes in the string. */
size_t hash, /* The string's hash. If the value is
| | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
Tcl_Size length, /* Number of bytes in the string. */
size_t hash, /* The string's hash. If the value is
* TCL_INDEX_NONE, it will be computed here. */
int *newPtr,
Namespace *nsPtr,
int flags,
LiteralEntry **globalPtrPtr)
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 | * Literals should always have UTF-8 representations... but this * is not guaranteed so we need to be careful anyway. * * https://stackoverflow.com/q/54337750/301832 */ Tcl_Size objLength; | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
* Literals should always have UTF-8 representations... but this
* is not guaranteed so we need to be careful anyway.
*
* https://stackoverflow.com/q/54337750/301832
*/
Tcl_Size objLength;
const char *objBytes = TclGetStringFromObj(objPtr, &objLength);
if ((objLength == length) && ((length == 0)
|| ((objBytes[0] == bytes[0])
&& (memcmp(objBytes, bytes, length) == 0)))) {
/*
* A literal was found: return it
*/
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 |
* that was previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *entryPtr;
const char *bytes;
| | | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
* that was previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *entryPtr;
const char *bytes;
Tcl_Size globalHash, length;
bytes = TclGetStringFromObj(objPtr, &length);
globalHash = (HashString(bytes, length) & globalTablePtr->mask);
for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL;
entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
return entryPtr;
}
}
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 |
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
| | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 |
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
bytes = TclGetStringFromObj(newObjPtr, &length);
localHash = HashString(bytes, length) & localTablePtr->mask;
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
if (entryPtr == lPtr) {
*nextPtrPtr = lPtr->nextPtr;
lPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 |
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
{
char *bytes;
int found;
| | > | | 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 |
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
{
char *bytes;
int found;
size_t i;
Tcl_Size length;
found = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
localPtr=localPtr->nextPtr) {
if (localPtr->objPtr == objPtr) {
found = 1;
}
}
}
if (!found) {
bytes = TclGetStringFromObj(objPtr, &length);
Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
"AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
Tcl_Size length;
if (iPtr == NULL) {
goto done;
}
globalTablePtr = &iPtr->literalTable;
| | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
Tcl_Size length;
if (iPtr == NULL) {
goto done;
}
globalTablePtr = &iPtr->literalTable;
bytes = TclGetStringFromObj(objPtr, &length);
index = HashString(bytes, length) & globalTablePtr->mask;
/*
* Check to see if the object is in the global literal table and remove
* this reference. The object may not be in the table if it is a hidden
* local literal.
*/
|
| ︙ | ︙ | |||
1015 1016 1017 1018 1019 1020 1021 |
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
| | | 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 |
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
bytes = TclGetStringFromObj(entryPtr->objPtr, &length);
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
bucketPtr = &tablePtr->buckets[index];
entryPtr->nextPtr = *bucketPtr;
*bucketPtr = entryPtr;
}
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
TclVerifyLocalLiteralTable(
CompileEnv *envPtr) /* Points to CompileEnv whose literal table is
* to be validated. */
{
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
char *bytes;
| | > | | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 |
TclVerifyLocalLiteralTable(
CompileEnv *envPtr) /* Points to CompileEnv whose literal table is
* to be validated. */
{
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
char *bytes;
size_t i, count = 0;
Tcl_Size length;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != TCL_INDEX_NONE) {
bytes = TclGetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
"TclVerifyLocalLiteralTable",
(length>60? 60 : (int) length), bytes, localPtr->refCount);
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
|
| ︙ | ︙ | |||
1228 1229 1230 1231 1232 1233 1234 |
TclVerifyGlobalLiteralTable(
Interp *iPtr) /* Points to interpreter whose global literal
* table is to be validated. */
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
char *bytes;
| | > | | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 |
TclVerifyGlobalLiteralTable(
Interp *iPtr) /* Points to interpreter whose global literal
* table is to be validated. */
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
char *bytes;
size_t i, count = 0;
Tcl_Size length;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
if (globalPtr->refCount + 1 < 2) {
bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
"TclVerifyGlobalLiteralTable",
(length>60? 60 : (int)length), bytes, globalPtr->refCount);
}
if (globalPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyGlobalLiteralTable");
|
| ︙ | ︙ |
Changes to generic/tclLoad.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call * to Tcl_StaticLibrary). All such libraries are linked together into a * single list for the process. */ |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | /* * Prototypes for functions that are private to this file: */ static void LoadCleanupProc(void *clientData, Tcl_Interp *interp); | | | < > | < > | < | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
/*
* Prototypes for functions that are private to this file:
*/
static void LoadCleanupProc(void *clientData,
Tcl_Interp *interp);
static int IsStatic(LoadedLibrary *libraryPtr);
static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
LoadedLibrary *library, int keepLibrary,
const char *fullFileName, int interpExiting);
static int
IsStatic(
LoadedLibrary *libraryPtr)
{
return (libraryPtr->fileName[0] == '\0');
}
/*
*----------------------------------------------------------------------
*
* Tcl_LoadObjCmd --
*
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
const char *p, *fullFileName, *prefix;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch = 0;
size_t len;
int flags = 0;
Tcl_Obj *const *savedobjv = objv;
static const char *const options[] = {
| | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
const char *p, *fullFileName, *prefix;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch = 0;
size_t len;
int flags = 0;
Tcl_Obj *const *savedobjv = objv;
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
enum loadOptionsEnum {
LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST
} index;
while (objc > 2) {
if (TclGetString(objv[1])[0] != '-') {
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
} else if (LOAD_LAZY == index) {
flags |= TCL_LOAD_LAZY;
} else {
break;
}
}
if ((objc < 2) || (objc > 4)) {
| | > | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
} else if (LOAD_LAZY == index) {
flags |= TCL_LOAD_LAZY;
} else {
break;
}
}
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, savedobjv,
"?-global? ?-lazy? ?--? fileName ?prefix? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
fullFileName = TclGetString(objv[1]);
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
prefix = NULL;
}
}
if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
| | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
prefix = NULL;
}
}
if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out which interpreter we're going to load the library into.
*/
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 | * Can't have two different libraries loaded from the same file. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" is already loaded for prefix \"%s\"", fullFileName, libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 |
* Can't have two different libraries loaded from the same file.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" is already loaded for prefix \"%s\"",
fullFileName, libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"SPLITPERSONALITY", (char *)NULL);
code = TCL_ERROR;
Tcl_MutexUnlock(&libraryMutex);
goto done;
}
}
Tcl_MutexUnlock(&libraryMutex);
if (libraryPtr == NULL) {
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
* if the desired library is a static one.
*/
if (fullFileName[0] == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no library with prefix \"%s\" is loaded statically", prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
| | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 |
* if the desired library is a static one.
*/
if (fullFileName[0] == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no library with prefix \"%s\" is loaded statically", prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out the prefix if it wasn't provided explicitly.
*/
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
|| Tcl_UniCharIsDigit(UCHAR(ch))) {
break;
}
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 |
|| Tcl_UniCharIsDigit(UCHAR(ch))) {
break;
}
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot figure out prefix for %s",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"WHATLIBRARY", (char *)NULL);
code = TCL_ERROR;
goto done;
}
Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess);
Tcl_DecrRefCount(splitPtr);
/*
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
* Invoke the library's initialization function (either the normal one or
* the safe one, depending on whether or not the interpreter is safe).
*/
if (Tcl_IsSafe(target)) {
if (libraryPtr->safeInitProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | | 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 |
* Invoke the library's initialization function (either the normal one or
* the safe one, depending on whether or not the interpreter is safe).
*/
if (Tcl_IsSafe(target)) {
if (libraryPtr->safeInitProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot use library in a safe interpreter: no"
" %s_SafeInit procedure", libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
code = libraryPtr->safeInitProc(target);
} else {
if (libraryPtr->initProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot attach library to interpreter: no %s_Init procedure",
libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
code = libraryPtr->initProc(target);
}
/*
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 | } /* *---------------------------------------------------------------------- * * Tcl_UnloadObjCmd -- * | | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 | } /* *---------------------------------------------------------------------- * * Tcl_UnloadObjCmd -- * * Implements the "unload" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. |
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
prefix = NULL;
}
}
if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
| | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
prefix = NULL;
}
}
if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out which interpreter we're going to load the library into.
*/
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 | * It's an error to try unload a static library. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "library with prefix \"%s\" is loaded statically and cannot be unloaded", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", | | | | 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 |
* It's an error to try unload a static library.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"library with prefix \"%s\" is loaded statically and cannot be unloaded",
prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
if (libraryPtr == NULL) {
/*
* The DLL pointed by the provided filename has never been loaded.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" has never been loaded", fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
/*
* Scan through the list of libraries already loaded in the target
* interpreter. If the library we want is already loaded there, then we
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 | * The library has not been loaded in this interpreter. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" has never been loaded in this interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", | | < | | | | | | < | | < < | 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 |
* The library has not been loaded in this interpreter.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" has never been loaded in this interpreter",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0);
done:
Tcl_DStringFree(&pfx);
Tcl_DStringFree(&tmp);
if (!complain && (code != TCL_OK)) {
code = TCL_OK;
Tcl_ResetResult(interp);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* UnloadLibrary --
*
* Unloads a library from an interpreter, and also from the process if it
* is unloadable, i.e. if it provides an "unload" function.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See description.
*
*----------------------------------------------------------------------
*/
static int
UnloadLibrary(
Tcl_Interp *interp,
Tcl_Interp *target,
LoadedLibrary *libraryPtr,
int keepLibrary,
const char *fullFileName,
int interpExiting)
{
int code;
InterpLibrary *ipFirstPtr, *ipPtr;
LoadedLibrary *iterLibraryPtr;
int trustedRefCount = -1, safeRefCount = -1;
Tcl_LibraryUnloadProc *unloadProc = NULL;
/*
* Ensure that the DLL can be unloaded. If it is a trusted interpreter,
* libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If
* the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL.
*/
if (Tcl_IsSafe(target)) {
if (libraryPtr->safeUnloadProc == NULL) {
if (!interpExiting) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" cannot be unloaded under a safe interpreter",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
}
unloadProc = libraryPtr->safeUnloadProc;
} else {
if (libraryPtr->unloadProc == NULL) {
if (!interpExiting) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" cannot be unloaded under a trusted interpreter",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
(char *)NULL);
code = TCL_ERROR;
goto done;
}
}
unloadProc = libraryPtr->unloadProc;
}
/*
* We are ready to unload the library. First, evaluate the unload
* function. If this fails, we cannot proceed with unload. Also, we must
* specify the proper flag to pass to the unload callback.
* TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should
* only remove itself from the interpreter; the library will be unloaded
|
| ︙ | ︙ | |||
852 853 854 855 856 857 858 |
if (safeRefCount <= 0 && trustedRefCount <= 0) {
code = TCL_UNLOAD_DETACH_FROM_PROCESS;
}
}
code = unloadProc(target, code);
}
| < < > | > | | | | | | | | | | | | | | | | > | 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 |
if (safeRefCount <= 0 && trustedRefCount <= 0) {
code = TCL_UNLOAD_DETACH_FROM_PROCESS;
}
}
code = unloadProc(target, code);
}
if (code != TCL_OK) {
Tcl_TransferResult(target, code, interp);
goto done;
}
/*
* Remove this library from the interpreter's library cache.
*/
if (!interpExiting) {
ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
if (ipFirstPtr) {
ipPtr = ipFirstPtr;
if (ipPtr->libraryPtr == libraryPtr) {
ipFirstPtr = ipFirstPtr->nextPtr;
} else {
InterpLibrary *ipPrevPtr;
for (ipPrevPtr = ipPtr; ipPtr != NULL;
ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
if (ipPtr->libraryPtr == libraryPtr) {
ipPrevPtr->nextPtr = ipPtr->nextPtr;
break;
}
}
}
Tcl_Free(ipPtr);
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr);
}
}
if (IsStatic(libraryPtr)) {
goto done;
}
/*
* The unload function was called succesfully.
|
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 |
TclGetLoadedLibraries(
Tcl_Interp *interp, /* Interpreter in which to return information
* or error message. */
const char *targetName, /* Name of target interpreter or NULL. If
* NULL, return info about all interps;
* otherwise, just return info about this
* interpreter. */
| | | < | 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 |
TclGetLoadedLibraries(
Tcl_Interp *interp, /* Interpreter in which to return information
* or error message. */
const char *targetName, /* Name of target interpreter or NULL. If
* NULL, return info about all interps;
* otherwise, just return info about this
* interpreter. */
const char *prefix) /* Prefix or NULL. If NULL, return info
* for all prefixes. */
{
Tcl_Interp *target;
LoadedLibrary *libraryPtr;
InterpLibrary *ipPtr;
Tcl_Obj *resultObj, *pkgDesc[2];
if (targetName == NULL) {
|
| ︙ | ︙ | |||
1190 1191 1192 1193 1194 1195 1196 | * Storage for all of the InterpLibrary functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( | | | | < < < < | > > > > > | 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 |
* Storage for all of the InterpLibrary functions for interp get deleted.
*
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
void *clientData, /* Pointer to first InterpLibrary structure
* for interp. */
Tcl_Interp *interp)
{
InterpLibrary *ipPtr = (InterpLibrary *)clientData, *nextPtr;
LoadedLibrary *libraryPtr;
while (ipPtr) {
libraryPtr = ipPtr->libraryPtr;
UnloadLibrary(interp, interp, libraryPtr, 0, "", 1);
/* UnloadLibrary doesn't free it by interp delete, so do it here and
* repeat for next. */
nextPtr = ipPtr->nextPtr;
Tcl_Free(ipPtr);
ipPtr = nextPtr;
}
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeLoad --
|
| ︙ | ︙ |
Changes to generic/tclLoadNone.c.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | * (gracefully) that they fail. */ #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer( | < | < | | > < < < < | 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 |
* (gracefully) that they fail.
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
TCL_UNUSED(size_t))
{
return NULL;
}
MODULE_SCOPE int
TclpLoadMemory(
TCL_UNUSED(void *),
TCL_UNUSED(size_t),
TCL_UNUSED(Tcl_Size),
TCL_UNUSED(const char *),
TCL_UNUSED(Tcl_LoadHandle *),
TCL_UNUSED(Tcl_FSUnloadFileProc **),
TCL_UNUSED(int))
{
return TCL_ERROR;
}
#endif /* TCL_LOAD_FROM_MEMORY */
/*
* Local Variables:
|
| ︙ | ︙ |
Changes to generic/tclMain.c.
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetStartupScript(
Tcl_Obj *path, /* Filesystem path of startup script file */
| | | | | > > > > < < < | < < < | 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 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetStartupScript(
Tcl_Obj *path, /* Filesystem path of startup script file */
const char *encodingName) /* Encoding of the data in that file */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Obj *encodingObj = NULL;
if (encodingName != NULL) {
encodingObj = Tcl_NewStringObj(encodingName, -1);
Tcl_IncrRefCount(encodingObj);
}
if (path != NULL) {
Tcl_IncrRefCount(path);
}
if (tsdPtr->path != NULL) {
Tcl_DecrRefCount(tsdPtr->path);
}
tsdPtr->path = path;
if (tsdPtr->encoding != NULL) {
Tcl_DecrRefCount(tsdPtr->encoding);
}
tsdPtr->encoding = encodingObj;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStartupScript --
*
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
* (const char *) that points to the
* registered encoding name for the startup
* script. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (encodingPtr != NULL) {
| | | | | > | 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 |
* (const char *) that points to the
* registered encoding name for the startup
* script. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (encodingPtr != NULL) {
if (tsdPtr->encoding != NULL) {
*encodingPtr = Tcl_GetString(tsdPtr->encoding);
} else {
*encodingPtr = NULL;
}
}
return tsdPtr->path;
}
/*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
*
* This function is typically invoked by Tcl_Main of Tk_Main function to
* source an application specific rc file into the interpreter at startup
* time. If the filename cannot be translated (e.g. it referred to a bogus
* user or there was no HOME environment variable). Just do nothing.
*
* Results:
* None.
*
* Side effects:
* Depends on what's in the rc script.
*
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
| | < < < < < < | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
if (fullName != NULL) {
/*
* Test for the existence of the rc file before trying to read it.
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
Tcl_CloseEx(NULL, c, 0);
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 |
InteractiveState is;
TclpSetInitialEncodings();
if (argc > 0) {
--argc; /* consume argv[0] */
++i;
}
| | | < | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 |
InteractiveState is;
TclpSetInitialEncodings();
if (argc > 0) {
--argc; /* consume argv[0] */
++i;
}
TclpFindExecutable((const char *)argv[0]); /* nb: this could be NULL
* w/ (eg) an empty argv supplied to execve() */
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
TclNewObj(is.commandPtr);
|
| ︙ | ︙ | |||
329 330 331 332 333 334 335 |
*/
/* mind argc is being adjusted as we proceed */
if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2]);
Tcl_SetStartupScript(NewNativeObj(argv[3]),
| | | | | 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 |
*/
/* mind argc is being adjusted as we proceed */
if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2]);
Tcl_SetStartupScript(NewNativeObj(argv[3]),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
i += 3;
} else if ((argc >= 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
argc--;
i++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
appName = path;
} else if (argv[0]) {
appName = NewNativeObj(argv[0]);
} else {
appName = Tcl_NewStringObj("tclsh", -1);
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++]));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewBooleanObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
| | < < | < < | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 |
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *valuePtr = NULL;
TclDictGet(NULL, options, "-errorinfo", &valuePtr);
if (valuePtr) {
if (Tcl_WriteObj(chan, valuePtr) < 0) {
Tcl_WriteChars(chan, ENCODING_ERROR, -1);
}
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | */ static void DeleteImportedCmd(void *clientData); static int DoImport(Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite); | | > | | | > | 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 | */ static void DeleteImportedCmd(void *clientData); static int DoImport(Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite); static void DupNsNameInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static char * ErrorCodeRead(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static char * ErrorInfoRead(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static char * EstablishErrorCodeTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static char * EstablishErrorInfoTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedNRCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static Tcl_ObjCmdProc NamespaceChildrenCmd; static Tcl_ObjCmdProc NamespaceCodeCmd; static Tcl_ObjCmdProc NamespaceCurrentCmd; static Tcl_ObjCmdProc NamespaceDeleteCmd; static Tcl_ObjCmdProc NamespaceEvalCmd; static Tcl_ObjCmdProc NRNamespaceEvalCmd; static Tcl_ObjCmdProc NamespaceExistsCmd; |
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetNsNameFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
| | | | | | | | 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 |
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetNsNameFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define NsNameSetInternalRep(objPtr, nnPtr) \
do { \
Tcl_ObjInternalRep ir; \
(nnPtr)->refCount++; \
ir.twoPtrValue.ptr1 = (nnPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &nsNameType, &ir); \
} while (0)
#define NsNameGetInternalRep(objPtr, nnPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &nsNameType); \
(nnPtr) = irPtr ? (ResolvedNsName *) irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
{"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
{"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0},
{"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
{"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* TclInitNamespaceSubsystem --
*
* This function is called to initialize all the structures that are used
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
{"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
{"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0},
{"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
{"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* CreateChildEntry --
*
* Create a child namespace hash table entry.
*
* Results:
* Handle to hash table entry for a child namespace with the given name.
* Caller should handle filling in the namespace value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static inline Tcl_HashEntry *
CreateChildEntry(
Namespace *nsPtr, /* Parent namespace. */
const char *name, /* Simple name to look for. */
int *isNewPtr) /* Pointer to var with whether this is new. */
{
#ifndef BREAK_NAMESPACE_COMPAT
return Tcl_CreateHashEntry(&nsPtr->childTable, name, isNewPtr);
#else
if )nsPtr->childTablePtr == NULL) {
nsPtr->childTablePtr = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(nsPtr->childTablePtr, TCL_STRING_KEYS);
}
return Tcl_CreateHashEntry(nsPtr->childTablePtr, name, isNewPtr);
#endif
}
/*
*----------------------------------------------------------------------
*
* FindChildEntry --
*
* Look up a child namespace hash table entry.
*
* Results:
* Handle to hash table entry if a child namespace with the given name
* exists, otherwise NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static inline Tcl_HashEntry *
FindChildEntry(
Namespace *nsPtr, /* Parent namespace. */
const char *name) /* Simple name to look for. */
{
#ifndef BREAK_NAMESPACE_COMPAT
return Tcl_FindHashEntry(&nsPtr->childTable, name);
#else
return nsPtr->childTablePtr ?
Tcl_FindHashEntry(nsPtr->childTablePtr, name) : NULL;
#endif
}
/*
*----------------------------------------------------------------------
*
* FirstChildEntry --
*
* Start an iteration through the collection of child namespaces.
*
* Results:
* Handle to hash table entry if a child namespace exists, otherwise NULL.
*
* Side effects:
* Updates the search handle.
*
*----------------------------------------------------------------------
*/
static inline Tcl_HashEntry *
FirstChildEntry(
Namespace *nsPtr, /* Parent namespace. */
Tcl_HashSearch *searchPtr) /* Iteration handle reference. */
{
#ifndef BREAK_NAMESPACE_COMPAT
return Tcl_FirstHashEntry(&nsPtr->childTable, searchPtr);
#else
return nsPtr->childTablePtr ?
Tcl_FirstHashEntry(nsPtr->childTablePtr, searchPtr) : NULL;
#endif
}
/*
*----------------------------------------------------------------------
*
* NumChildEntries --
*
* Get the count of child namespaces.
*
* Results:
* Number of child entries.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static inline Tcl_Size
NumChildEntries(
Namespace *nsPtr)
{
#ifndef BREAK_NAMESPACE_COMPAT
return nsPtr->childTable.numEntries;
#else
return nsPtr->childTablePtr ? nsPtr->childTablePtr->numEntries : 0;
#endif
}
/*
*----------------------------------------------------------------------
*
* TclInitNamespaceSubsystem --
*
* This function is called to initialize all the structures that are used
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace( | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetCurrentNamespace(
Tcl_Interp *interp) /* Interpreter whose current namespace is
* being queried. */
{
return TclGetCurrentNamespace(interp);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace( | | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetGlobalNamespace(
Tcl_Interp *interp) /* Interpreter whose global namespace should
* be returned. */
{
return TclGetGlobalNamespace(interp);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
457 458 459 460 461 462 463 |
* If new variables are created, they will be
* created in the frame. If 0, the frame is
* for a "namespace eval" or "namespace
* inscope" command and var references are
* treated as references to namespace
* variables. */
{
| | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
* If new variables are created, they will be
* created in the frame. If 0, the frame is
* for a "namespace eval" or "namespace
* inscope" command and var references are
* treated as references to namespace
* variables. */
{
*framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame));
return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
isProcCallFrame);
}
void
TclPopStackFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
Tcl_CreateNamespace(
Tcl_Interp *interp, /* Interpreter in which a new namespace is
* being created. Also used for error
* reporting. */
const char *name, /* Name for the new namespace. May be a
* qualified name with names of ancestor
* namespaces separated by "::"s. */
| | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
Tcl_CreateNamespace(
Tcl_Interp *interp, /* Interpreter in which a new namespace is
* being created. Also used for error
* reporting. */
const char *name, /* Name for the new namespace. May be a
* qualified name with names of ancestor
* namespaces separated by "::"s. */
void *clientData, /* One-word value to store with namespace. */
Tcl_NamespaceDeleteProc *deleteProc)
/* Function called to delete client data when
* the namespace is deleted. NULL if no
* function should be called. */
{
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr, *ancestorPtr;
|
| ︙ | ︙ | |||
711 712 713 714 715 716 717 |
* If we've ended up with an empty string now, we're attempting to create
* the global namespace despite the global namespace existing. That's
* naughty!
*/
if (*name == '\0') {
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
| | | | 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 |
* If we've ended up with an empty string now, we're attempting to create
* the global namespace despite the global namespace existing. That's
* naughty!
*/
if (*name == '\0') {
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
" \"\": only global namespace can have empty name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEGLOBAL", (char *)NULL);
Tcl_DStringFree(&tmpBuffer);
return NULL;
}
/*
* Find the parent for the new namespace.
*/
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 |
}
/*
* Check for a bad namespace name and make sure that the name does not
* already exist in the parent namespace.
*/
| < < < < < | < < | | | | 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 |
}
/*
* Check for a bad namespace name and make sure that the name does not
* already exist in the parent namespace.
*/
if (FindChildEntry(parentPtr, simpleName) != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create namespace \"%s\": already exists", name));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEEXISTING", (char *)NULL);
Tcl_DStringFree(&tmpBuffer);
return NULL;
}
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
*/
doCreate:
nsPtr = (Namespace *) Tcl_Alloc(sizeof(Namespace));
nameLen = strlen(simpleName) + 1;
nsPtr->name = (char *) Tcl_Alloc(nameLen);
memcpy(nsPtr->name, simpleName, nameLen);
nsPtr->fullName = NULL; /* Set below. */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
nsPtr->parentPtr = parentPtr;
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
nsPtr->unknownHandlerPtr = NULL;
nsPtr->commandPathLength = 0;
nsPtr->commandPathArray = NULL;
nsPtr->commandPathSourceList = NULL;
nsPtr->earlyDeleteProc = NULL;
if (parentPtr != NULL) {
| < < | | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
nsPtr->unknownHandlerPtr = NULL;
nsPtr->commandPathLength = 0;
nsPtr->commandPathArray = NULL;
nsPtr->commandPathSourceList = NULL;
nsPtr->earlyDeleteProc = NULL;
if (parentPtr != NULL) {
entryPtr = CreateChildEntry(parentPtr, simpleName, &newEntry);
Tcl_SetHashValue(entryPtr, nsPtr);
} else {
/*
* In the global namespace create traces to maintain the ::errorInfo
* and ::errorCode variables.
*/
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
| | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
nsPtr->fullName = (char *) Tcl_Alloc(nameLen + 1);
memcpy(nsPtr->fullName, name, nameLen + 1);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
Tcl_DStringFree(&tmpBuffer);
/*
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
*/
void
Tcl_DeleteNamespace(
Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
{
Namespace *nsPtr = (Namespace *) namespacePtr;
| | | < | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 |
*/
void
Tcl_DeleteNamespace(
Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
{
Namespace *nsPtr = (Namespace *) namespacePtr;
Tcl_Interp *interp = nsPtr->interp;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr;
/*
* Ensure that this namespace doesn't get deallocated in the meantime.
*/
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 |
*
* NOTE: we could avoid traversing the ns's command list by keeping a
* separate list of coros.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
| | | < | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
*
* NOTE: we could avoid traversing the ns's command list by keeping a
* separate list of coros.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (cmdPtr->nreProc == TclNRInterpCoroutine) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
} else {
entryPtr = Tcl_NextHashEntry(&search);
}
}
/*
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 | /* * Splice out and link to indicate that we've already been killed. */ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; ensemblePtr->next = ensemblePtr; | | | | | | | | | | | | | | | | | < < | | | | 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 |
/*
* Splice out and link to indicate that we've already been killed.
*/
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
ensemblePtr->next = ensemblePtr;
Tcl_DeleteCommandFromToken(interp, ensemblePtr->token);
}
/*
* If the namespace has a registered unknown handler (TIP 181), then free
* it here.
*/
if (nsPtr->unknownHandlerPtr != NULL) {
Tcl_DecrRefCount(nsPtr->unknownHandlerPtr);
nsPtr->unknownHandlerPtr = NULL;
}
/*
* If the namespace is on the call frame stack, it is marked as "dying"
* (NS_DYING is OR'd into its flags): Contents of the namespace are
* still available and visible until the namespace is later marked as
* NS_DEAD, and its commands and variables are still usable by any
* active call frames referring to th namespace. When all active call
* frames referring to the namespace have been popped from the Tcl
* stack, Tcl_PopCallFrame calls Tcl_DeleteNamespace again. If no
* nsName objects refer to the namespace (i.e., if its refCount is
* zero), its commands and variables are deleted and the storage for
* its namespace structure is freed. Otherwise, if its refCount is
* nonzero, the namespace's commands and variables are deleted but the
* structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
* flags to allow the namespace resolution code to recognize that the
* namespace is "deleted". The structure's storage is freed by
* FreeNsNameInternalRep when its refCount reaches 0.
*/
if (nsPtr->activationCount > (nsPtr == globalNsPtr)) {
nsPtr->flags |= NS_DYING;
if (nsPtr->parentPtr != NULL) {
entryPtr = FindChildEntry(nsPtr->parentPtr, nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
nsPtr->parentPtr = NULL;
} else if (!(nsPtr->flags & NS_TEARDOWN)) {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
* interpreter is being torn down. Set the NS_TEARDOWN flag to avoid
* recursive calls here - if the namespace is really in the process of
* being deleted, ignore any second call.
*/
nsPtr->flags |= NS_DYING | NS_TEARDOWN;
TclTeardownNamespace(nsPtr);
if ((nsPtr != globalNsPtr) || (((Interp *) interp)->flags & DELETED)) {
/*
* If this is the global namespace, then it may have residual
* "errorInfo" and "errorCode" variables for errors that occurred
* while it was being torn down. Try to clear the variable list
* one last time.
*/
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
nsPtr ->flags |= NS_DEAD;
} else {
/*
* Restore the ::errorInfo and ::errorCode traces.
*/
| | | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
nsPtr ->flags |= NS_DEAD;
} else {
/*
* Restore the ::errorInfo and ::errorCode traces.
*/
EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
/*
* We didn't really kill it, so remove the KILLED marks, so it can
* get killed later, avoiding mem leaks.
*/
nsPtr->flags &= ~(NS_DYING|NS_TEARDOWN);
|
| ︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 |
Namespace *nsPtr)
{
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
void
TclDeleteNamespaceChildren(
| | < | > | < | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
Namespace *nsPtr)
{
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
void
TclDeleteNamespaceChildren(
Namespace *nsPtr) /* Namespace whose children to delete */
{
Tcl_Interp *interp = nsPtr->interp;
Tcl_HashEntry *entryPtr;
size_t i;
int unchecked;
Tcl_HashSearch search;
/*
* Delete all the child namespaces.
*
* BE CAREFUL: When each child is deleted, it divorces itself from its
* parent. The hash table can't be properly traversed if its elements are
* being deleted. Because of traces (and the desire to avoid the
* quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
* f97d4ee020]) copy to a temporary array and then delete all those
* namespaces.
*
* Important: leave the hash table itself still live.
*/
unchecked = (NumChildEntries(nsPtr) > 0);
while (NumChildEntries(nsPtr) > 0 && unchecked) {
size_t length = NumChildEntries(nsPtr);
Namespace **children = (Namespace **)
TclStackAlloc(interp, sizeof(Namespace *) * length);
i = 0;
for (entryPtr = FirstChildEntry(nsPtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
children[i] = (Namespace *) Tcl_GetHashValue(entryPtr);
children[i]->refCount++;
i++;
}
unchecked = 0;
for (i = 0 ; i < length ; i++) {
if (!(children[i]->flags & NS_DYING)) {
unchecked = 1;
Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
TclNsDecrRefCount(children[i]);
}
}
TclStackFree(interp, children);
}
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
*
|
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 | * Deletes all commands, variables and namespaces in this namespace. * *---------------------------------------------------------------------- */ void TclTeardownNamespace( | | | | 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 |
* Deletes all commands, variables and namespaces in this namespace.
*
*----------------------------------------------------------------------
*/
void
TclTeardownNamespace(
Namespace *nsPtr) /* Points to the namespace to be dismantled
* and unlinked from its parent. */
{
Tcl_Interp *interp = nsPtr->interp;
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Size i;
/*
* Start by destroying the namespace's variable table, since variables
* might trigger traces. Variable table should be cleared but not freed!
|
| ︙ | ︙ | |||
1203 1204 1205 1206 1207 1208 1209 |
* problems of just using Tcl_FirstHashEntry over and over, [Bug
* f97d4ee020]) we copy to a temporary array and then delete all those
* commands.
*/
while (nsPtr->cmdTable.numEntries > 0) {
Tcl_Size length = nsPtr->cmdTable.numEntries;
| | | | < | < < | | 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 |
* problems of just using Tcl_FirstHashEntry over and over, [Bug
* f97d4ee020]) we copy to a temporary array and then delete all those
* commands.
*/
while (nsPtr->cmdTable.numEntries > 0) {
Tcl_Size length = nsPtr->cmdTable.numEntries;
Command **cmds = (Command **)TclStackAlloc(interp,
sizeof(Command *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
cmds[i] = (Command *) Tcl_GetHashValue(entryPtr);
cmds[i]->refCount++;
i++;
}
for (i = 0 ; i < length ; i++) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmds[i]);
TclCleanupCommandMacro(cmds[i]);
}
TclStackFree(interp, cmds);
}
Tcl_DeleteHashTable(&nsPtr->cmdTable);
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
/*
* Remove the namespace from its parent's child hashtable.
*/
if (nsPtr->parentPtr != NULL) {
entryPtr = FindChildEntry(nsPtr->parentPtr, nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
nsPtr->parentPtr = NULL;
/*
|
| ︙ | ︙ | |||
1313 1314 1315 1316 1317 1318 1319 | * None. * *---------------------------------------------------------------------- */ static void NamespaceFree( | | | 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
* None.
*
*----------------------------------------------------------------------
*/
static void
NamespaceFree(
Namespace *nsPtr) /* Points to the namespace to free. */
{
/*
* Most of the namespace's contents are freed when the namespace is
* deleted by Tcl_DeleteNamespace. All that remains is to free its names
* (for error messages), and the structure itself.
*/
|
| ︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 |
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
| | | | 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
" \"%s\": pattern can't specify a namespace", pattern));
Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", (char *)NULL);
return TCL_ERROR;
}
/*
* Make sure that we don't already have the pattern in the array
*/
|
| ︙ | ︙ | |||
1461 1462 1463 1464 1465 1466 1467 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
| | | | 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
nsPtr->exportArrayPtr = (char **) Tcl_Realloc(nsPtr->exportArrayPtr,
sizeof(char *) * nsPtr->maxExportPatterns);
}
/*
* Add the pattern to the namespace's array of export patterns.
*/
len = strlen(pattern);
patternCpy = (char *) Tcl_Alloc(len + 1);
memcpy(patternCpy, pattern, len + 1);
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
nsPtr->numExportPatterns++;
/*
* The list of commands actually exported from the namespace might have
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 | * object. * *---------------------------------------------------------------------- */ int Tcl_AppendExportList( | | > | 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 |
* object.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppendExportList(
Tcl_Interp *interp, /* Interpreter used for global NS and error
* reporting. */
Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
* pattern list is appended onto objPtr. NULL
* for the current namespace. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* export pattern list is appended. */
{
Namespace *nsPtr;
|
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 |
* imported commands in autoloaded libraries and loads them in. That way,
* they will be found when we try to create links below.
*
* Note that we don't just call Tcl_EvalObjv() directly because we do not
* want absence of the command to be a failure case.
*/
| | | 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
* imported commands in autoloaded libraries and loads them in. That way,
* they will be found when we try to create links below.
*
* Note that we don't just call Tcl_EvalObjv() directly because we do not
* want absence of the command to be a failure case.
*/
if (Tcl_FindCommand(interp, "auto_import", NULL, TCL_GLOBAL_ONLY) != NULL) {
Tcl_Obj *objv[2];
int result;
TclNewLiteralStringObj(objv[0], "auto_import");
objv[1] = Tcl_NewStringObj(pattern, -1);
Tcl_IncrRefCount(objv[0]);
|
| ︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 |
/*
* From the pattern, find the namespace from which we are importing and
* get the simple pattern (no namespace qualifiers or ::'s) at the end.
*/
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
| | | | | | | | | | 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 |
/*
* From the pattern, find the namespace from which we are importing and
* get the simple pattern (no namespace qualifiers or ::'s) at the end.
*/
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", (char *)NULL);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace in import pattern \"%s\"", pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, (char *)NULL);
return TCL_ERROR;
}
if (importNsPtr == nsPtr) {
if (pattern == simplePattern) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no namespace specified in import pattern \"%s\"",
pattern));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", (char *)NULL);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"import pattern \"%s\" tries to import from namespace"
" \"%s\" into itself", pattern, importNsPtr->name));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", (char *)NULL);
}
return TCL_ERROR;
}
/*
* Scan through the command table in the source namespace and look for
* exported commands that match the string pattern. Create an "imported
|
| ︙ | ︙ | |||
1682 1683 1684 1685 1686 1687 1688 |
return TCL_OK;
}
return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
importNsPtr, allowOverwrite);
}
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
| | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
return TCL_OK;
}
return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
importNsPtr, allowOverwrite);
}
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
char *cmdName = (char *) Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern) &&
DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
allowOverwrite) == TCL_ERROR) {
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 |
/*
* The command cmdName in the source namespace matches the pattern. Check
* whether it was exported. If it wasn't, we ignore it.
*/
while (!exported && (i < importNsPtr->numExportPatterns)) {
| | < | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 |
/*
* The command cmdName in the source namespace matches the pattern. Check
* whether it was exported. If it wasn't, we ignore it.
*/
while (!exported && (i < importNsPtr->numExportPatterns)) {
exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]);
}
if (!exported) {
return TCL_OK;
}
/*
* Unless there is a name clash, create an imported command in the current
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 | Tcl_DStringAppend(&ds, cmdName, -1); /* * Check whether creating the new imported command in the current * namespace would create a cycle of imported command references. */ | | | | | | | | | | | | > | | | 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 |
Tcl_DStringAppend(&ds, cmdName, -1);
/*
* Check whether creating the new imported command in the current
* namespace would create a cycle of imported command references.
*/
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
Command *overwrite = (Command *) Tcl_GetHashValue(found);
Command *linkCmd = cmdPtr;
while (linkCmd->deleteProc == DeleteImportedCmd) {
dataPtr = (ImportedCmdData *) linkCmd->objClientData;
linkCmd = dataPtr->realCmdPtr;
if (overwrite == linkCmd) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"import pattern \"%s\" would create a loop"
" containing command \"%s\"",
pattern, Tcl_DStringValue(&ds)));
Tcl_DStringFree(&ds);
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", (char *)NULL);
return TCL_ERROR;
}
}
}
dataPtr = (ImportedCmdData *) Tcl_Alloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
/* corresponding decrement is in DeleteImportedCmd */
cmdPtr->refCount++;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
Tcl_DStringFree(&ds);
/*
* Create an ImportRef structure describing this new import command
* and add it to the import ref list in the "real" command.
*/
refPtr = (ImportRef *) Tcl_Alloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
} else {
Command *overwrite = (Command *) Tcl_GetHashValue(found);
if (overwrite->deleteProc == DeleteImportedCmd) {
ImportedCmdData *dataPtr = (ImportedCmdData *)
overwrite->objClientData;
if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) {
/*
* Repeated import of same command is acceptable.
*/
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't import command \"%s\": already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1895 1896 1897 1898 1899 1900 1901 |
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace in namespace forget pattern \"%s\"",
pattern));
| | | | | | | > | | 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 |
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace in namespace forget pattern \"%s\"",
pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, (char *)NULL);
return TCL_ERROR;
}
if (strcmp(pattern, simplePattern) == 0) {
/*
* The pattern is simple. Delete any imported commands that match it.
*/
if (TclMatchIsTrivial(simplePattern)) {
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (hPtr != NULL) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
}
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc != DeleteImportedCmd) {
continue;
}
cmdName = (char *) Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
}
return TCL_OK;
}
/*
* The pattern was namespace-qualified.
*/
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_CmdInfo info;
Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
Tcl_Command origin = TclGetOriginalCommand(token);
if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
continue; /* Not an imported command. */
}
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
/*
* Original not in namespace we're matching. Check the first link
* in the import chain.
*/
Command *cmdPtr = (Command *) token;
ImportedCmdData *dataPtr = (ImportedCmdData *)
cmdPtr->objClientData;
Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
if (firstToken == origin) {
continue;
}
Tcl_GetCommandInfoFromToken(firstToken, &info);
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
continue;
}
origin = firstToken;
}
if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
Tcl_DeleteCommandFromToken(interp, token);
}
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 |
Tcl_Command
TclGetOriginalCommand(
Tcl_Command command) /* The imported command for which the original
* command should be returned. */
{
Command *cmdPtr = (Command *) command;
| < | | 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 |
Tcl_Command
TclGetOriginalCommand(
Tcl_Command command) /* The imported command for which the original
* command should be returned. */
{
Command *cmdPtr = (Command *) command;
if (cmdPtr->deleteProc != DeleteImportedCmd) {
return NULL;
}
while (cmdPtr->deleteProc == DeleteImportedCmd) {
ImportedCmdData *dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
cmdPtr = dataPtr->realCmdPtr;
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2032 2033 2034 2035 2036 2037 2038 | * wrong, the result object is set to an error message. * *---------------------------------------------------------------------- */ static int InvokeImportedNRCmd( | | | | | 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 |
* wrong, the result object is set to an error message.
*
*----------------------------------------------------------------------
*/
static int
InvokeImportedNRCmd(
void *clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
TclSkipTailcall(interp);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
int
TclInvokeImportedCmd(
void *clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData,
objc, objv);
|
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 | * Removes the imported command from the real command's import list. * *---------------------------------------------------------------------- */ static void DeleteImportedCmd( | | | | 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 |
* Removes the imported command from the real command's import list.
*
*----------------------------------------------------------------------
*/
static void
DeleteImportedCmd(
void *clientData) /* Points to the imported command's
* ImportedCmdData structure. */
{
ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
Command *selfPtr = dataPtr->selfPtr;
ImportRef *refPtr, *prevPtr;
prevPtr = NULL;
for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
refPtr = refPtr->nextPtr) {
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 |
* NULL. */
const char **simpleNamePtr) /* Address where function stores the simple
* name at end of the qualName, or NULL if
* qualName is "::" or the flag
* TCL_FIND_ONLY_NS was specified. */
{
Interp *iPtr = (Interp *) interp;
| | | 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 |
* NULL. */
const char **simpleNamePtr) /* Address where function stores the simple
* name at end of the qualName, or NULL if
* qualName is "::" or the flag
* TCL_FIND_ONLY_NS was specified. */
{
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr = cxtNsPtr, *lastNsPtr = NULL, *lastAltNsPtr = NULL;
Namespace *altNsPtr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
const char *start, *end;
const char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
|
| ︙ | ︙ | |||
2256 2257 2258 2259 2260 2261 2262 |
nsPtr = globalNsPtr;
} else if (nsPtr == NULL) {
nsPtr = iPtr->varFramePtr->nsPtr;
}
start = qualName; /* Points to start of qualifying
* namespace. */
| | | | | | 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 |
nsPtr = globalNsPtr;
} else if (nsPtr == NULL) {
nsPtr = iPtr->varFramePtr->nsPtr;
}
start = qualName; /* Points to start of qualifying
* namespace. */
if ((qualName[0] == ':') && (qualName[1] == ':')) {
start = qualName + 2; /* Skip over the initial :: */
while (start[0] == ':') {
start++; /* Skip over a subsequent : */
}
nsPtr = globalNsPtr;
if (start[0] == '\0') { /* qualName is just two or more
* ":"s. */
*nsPtrPtr = globalNsPtr;
*altNsPtrPtr = NULL;
*actualCxtPtrPtr = globalNsPtr;
*simpleNamePtr = start; /* Points to empty string. */
return TCL_OK;
}
|
| ︙ | ︙ | |||
2302 2303 2304 2305 2306 2307 2308 |
* the end of the qualified name (i.e., a name ending in "\0"). Set
* len to the number of characters, starting from start, in the name;
* set end to point after the "::"s or at the "\0".
*/
len = 0;
for (end = start; *end != '\0'; end++) {
| | | < < < < > | 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 |
* the end of the qualified name (i.e., a name ending in "\0"). Set
* len to the number of characters, starting from start, in the name;
* set end to point after the "::"s or at the "\0".
*/
len = 0;
for (end = start; *end != '\0'; end++) {
if ((end[0] == ':') && (end[1] == ':')) {
end += 2; /* Skip over the initial :: */
while (*end == ':') {
end++; /* Skip over the subsequent : */
}
break; /* Exit for loop; end is after ::'s */
}
len++;
}
if (end[0]=='\0' && !(end-start>=2 && end[-1]==':' && end[-2]==':')) {
/*
* qualName ended with a simple name at start. If TCL_FIND_ONLY_NS
* was specified, look this up as a namespace. Otherwise, start is
* the name of a cmd or var and we are done.
*/
if (flags & TCL_FIND_ONLY_NS) {
nsName = start;
} else {
*simpleNamePtr = start;
goto done;
}
} else {
/*
* start points to the beginning of a namespace qualifier ending
* in "::". end points to the start of a name in that namespace
* that might be empty. Copy the namespace qualifier to a buffer
* so it can be null terminated. We can't modify the incoming
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 |
* Look up the namespace qualifier nsName in the current namespace
* context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
* create that qualifying namespace. This is needed for functions like
* Tcl_CreateObjCommand that cannot fail.
*/
if (nsPtr != NULL) {
| < < < < | < < < < | > > | > | > < < < < < < | < < | > > > > > > > > | | > > > < < > | > | 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 |
* Look up the namespace qualifier nsName in the current namespace
* context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
* create that qualifying namespace. This is needed for functions like
* Tcl_CreateObjCommand that cannot fail.
*/
if (nsPtr != NULL) {
entryPtr = FindChildEntry(nsPtr, nsName);
if (entryPtr != NULL) {
nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
} else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
Tcl_CallFrame *framePtr;
(void) TclPushStackFrame(interp, &framePtr,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
nsPtr = (Namespace *)
Tcl_CreateNamespace(interp, nsName, NULL, NULL);
TclPopStackFrame(interp);
if (nsPtr == NULL) {
Tcl_Panic("Could not create namespace '%s'", nsName);
}
} else {
/*
* Namespace not found and was not created.
* Remember last found namespace for TCL_FIND_IF_NOT_SIMPLE.
*/
lastNsPtr = nsPtr;
nsPtr = NULL;
}
}
/*
* Look up the namespace qualifier in the alternate search path too.
*/
if (altNsPtr != NULL) {
entryPtr = FindChildEntry(altNsPtr, nsName);
if (entryPtr != NULL) {
altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
} else {
/* Remember last found in alternate path */
lastAltNsPtr = altNsPtr;
altNsPtr = NULL;
}
}
/*
* If both search paths have failed, return NULL results.
*/
if ((nsPtr == NULL) && (altNsPtr == NULL)) {
if (flags & TCL_FIND_IF_NOT_SIMPLE) {
/*
* return last found NS, regardless simple name or not,
* e. g. ::A::B::C::D -> ::A::B and C::D, if namespace C
* cannot be found in ::A::B
*/
nsPtr = lastNsPtr;
altNsPtr = lastAltNsPtr;
*simpleNamePtr = start;
goto done;
}
*simpleNamePtr = NULL;
goto done;
}
start = end;
}
/*
* We ignore trailing "::"s in a namespace name, but in a command or
* variable name, trailing "::"s refer to the cmd or var named {}.
*/
if ((flags & TCL_FIND_ONLY_NS) || (end>start && end[-1]!=':')) {
*simpleNamePtr = NULL; /* Found namespace name. */
} else {
*simpleNamePtr = end; /* Found cmd/var: points to empty
* string. */
}
/*
* As a special case, if we are looking for a namespace and qualName is ""
* and the current active namespace (nsPtr) is not the global namespace,
* return NULL (no namespace was found). This is because namespaces can
* not have empty names except for the global namespace.
*/
if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0')
&& (nsPtr != globalNsPtr)) {
nsPtr = NULL;
}
done:
*nsPtrPtr = nsPtr;
*altNsPtrPtr = altNsPtr;
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2507 2508 2509 2510 2511 2512 2513 |
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or
* if the name starts with "::". Otherwise,
* points to namespace in which to resolve
* name; if NULL, look up name in the current
* namespace. */
| | | 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 |
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or
* if the name starts with "::". Otherwise,
* points to namespace in which to resolve
* name; if NULL, look up name in the current
* namespace. */
int flags) /* Flags controlling namespace lookup: an OR'd
* combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG flags. */
{
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
const char *dummy;
/*
|
| ︙ | ︙ | |||
2529 2530 2531 2532 2533 2534 2535 |
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 |
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, (char *)NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2619 2620 2621 2622 2623 2624 2625 |
result = resPtr->cmdResProc(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
| | | 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 |
result = resPtr->cmdResProc(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
((Command *) cmd)->flags |= CMD_VIA_RESOLVER;
return cmd;
} else if (result != TCL_CONTINUE) {
return NULL;
}
}
|
| ︙ | ︙ | |||
2645 2646 2647 2648 2649 2650 2651 |
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
|| !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
| | | | | 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
|| !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
}
}
}
/*
* Next, check along the path.
*/
for (i=0 ; (cmdPtr == NULL) && i<cxtNsPtr->commandPathLength ; i++) {
pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
if (pathNsPtr == NULL) {
continue;
}
(void) TclGetNamespaceForQualName(interp, name, pathNsPtr,
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
&& !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
}
}
}
/*
* If we've still not found the command, look in the global namespace
* as a last resort.
*/
if (cmdPtr == NULL) {
(void) TclGetNamespaceForQualName(interp, name, NULL,
TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
&& !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
}
}
}
} else {
Namespace *nsPtr[2];
int search;
|
| ︙ | ︙ | |||
2706 2707 2708 2709 2710 2711 2712 |
*/
for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
if (entryPtr != NULL) {
| | | | | | 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 |
*/
for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
}
}
}
}
if (cmdPtr != NULL) {
cmdPtr->flags &= ~CMD_VIA_RESOLVER;
return (Tcl_Command) cmdPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown command \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, (char *)NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2770 2771 2772 2773 2774 2775 2776 |
Tcl_HashEntry *hPtr;
Namespace *nsPtr;
Namespace *trailNsPtr, *shadowNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
int found, i;
int trailFront = -1;
int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */
| | > | < < | < < < < < < < < | | 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 |
Tcl_HashEntry *hPtr;
Namespace *nsPtr;
Namespace *trailNsPtr, *shadowNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
int found, i;
int trailFront = -1;
int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */
Namespace **trailPtr = (Namespace **) TclStackAlloc(interp,
trailSize * sizeof(Namespace *));
/*
* Start at the namespace containing the new command, and work up through
* the list of parents. Stop just before the global namespace, since the
* global namespace can't "shadow" its own entries.
*
* The namespace "trail" list we build consists of the names of each
* namespace that encloses the new command, in order from outermost to
* innermost: for example, "a" then "b". Each iteration of this loop
* eventually extends the trail upwards by one namespace, nsPtr. We use
* this trail list to see if nsPtr (e.g. "a" in 2. above) could have
* now-invalid cached command references. This will happen if nsPtr
* (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that
* there is a identically-named sequence of child namespaces starting from
* :: (e.g. "::b") whose tail namespace contains a command also named
* cmdName.
*/
cmdName = (char *)
Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ;
nsPtr=nsPtr->parentPtr) {
/*
* Find the maximal sequence of child namespaces contained in nsPtr
* such that there is a identically-named sequence of child namespaces
* starting from ::. shadowNsPtr will be the tail of this sequence, or
* the deepest namespace under :: that might contain a command now
* shadowed by cmdName. We check below if shadowNsPtr actually
* contains a command cmdName.
*/
found = 1;
shadowNsPtr = globalNsPtr;
for (i = trailFront; i >= 0; i--) {
trailNsPtr = trailPtr[i];
hPtr = FindChildEntry(shadowNsPtr, trailNsPtr->name);
if (hPtr != NULL) {
shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
} else {
found = 0;
break;
}
}
/*
|
| ︙ | ︙ | |||
2845 2846 2847 2848 2849 2850 2851 | /* * If the shadowed command was compiled to bytecodes, we * invalidate all the bytecodes in nsPtr, to force a new * compilation. We use the resolverEpoch to signal the need * for a fresh compilation of every bytecode. */ | | | > | | 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 |
/*
* If the shadowed command was compiled to bytecodes, we
* invalidate all the bytecodes in nsPtr, to force a new
* compilation. We use the resolverEpoch to signal the need
* for a fresh compilation of every bytecode.
*/
if (((Command *) Tcl_GetHashValue(hPtr))->compileProc != NULL) {
nsPtr->resolverEpoch++;
}
}
}
/*
* Insert nsPtr at the front of the trail list: i.e., at the end of
* the trailPtr array.
*/
trailFront++;
if (trailFront == trailSize) {
int newSize = 2 * trailSize;
trailPtr = (Namespace **)
TclStackRealloc(interp, trailPtr,
newSize * sizeof(Namespace *));
trailSize = newSize;
}
trailPtr[trailFront] = nsPtr;
}
TclStackFree(interp, trailPtr);
}
|
| ︙ | ︙ | |||
2914 2915 2916 2917 2918 2919 2920 | */ NamespaceCurrentCmd(NULL, interp, 1, NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "namespace \"%s\" not found in \"%s\"", name, Tcl_GetStringResult(interp))); } | | | 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 |
*/
NamespaceCurrentCmd(NULL, interp, 1, NULL);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"namespace \"%s\" not found in \"%s\"", name,
Tcl_GetStringResult(interp)));
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
GetNamespaceFromObj(
|
| ︙ | ︙ | |||
2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 |
NsNameGetInternalRep(objPtr, resNamePtr);
assert(resNamePtr != NULL);
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclInitNamespaceCmd --
*
* This function is called to create the "namespace" Tcl command. See the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 |
NsNameGetInternalRep(objPtr, resNamePtr);
assert(resNamePtr != NULL);
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclNewNamespaceObj --
*
* Gets an object that contains a reference to a given namespace.
*
* Note that this gets the name of the namespace immediately; this means
* that the name is guaranteed to persist even if the namespace is
* deleted. (This is checked by test namespace-7.1.)
*
* Results:
* Returns a newly-allocated Tcl_Obj.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclNewNamespaceObj(
Tcl_Namespace *namespacePtr)
{
Namespace *nsPtr = (Namespace *) namespacePtr;
Tcl_Size len;
Tcl_Obj *objPtr;
/*
* If NS_DEAD set, we have no name any more; the fullName field may have
* been deallocated.
*/
assert(!(nsPtr->flags & NS_DEAD));
/*
* Need to get the name pro-actively; the name must persist after the
* namespace is deleted. This is the easiest way.
*/
len = strlen(nsPtr->fullName);
TclNewStringObj(objPtr, nsPtr->fullName, len);
/*
* But we know exactly which namespace this resolves to. Remember that
* unless things are already being taken apart.
*/
if (!(nsPtr->flags & (NS_DYING | NS_TEARDOWN))) {
ResolvedNsName *resNamePtr = (ResolvedNsName *)
Tcl_Alloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
resNamePtr->refNsPtr = NULL;
resNamePtr->refCount = 0;
nsPtr->refCount++;
NsNameSetInternalRep(objPtr, resNamePtr);
}
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* TclInitNamespaceCmd --
*
* This function is called to create the "namespace" Tcl command. See the
|
| ︙ | ︙ | |||
3016 3017 3018 3019 3020 3021 3022 |
Tcl_Namespace *namespacePtr;
Namespace *nsPtr, *childNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
const char *pattern = NULL;
Tcl_DString buffer;
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
| | | | | 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 |
Tcl_Namespace *namespacePtr;
Namespace *nsPtr, *childNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
const char *pattern = NULL;
Tcl_DString buffer;
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Obj *listPtr;
/*
* Get a pointer to the specified namespace, or the current namespace.
*/
if (objc == 1) {
nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
} else if ((objc == 2) || (objc == 3)) {
if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
nsPtr = (Namespace *) namespacePtr;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?");
return TCL_ERROR;
}
/*
* Get the glob-style pattern, if any, used to narrow the search.
*/
Tcl_DStringInit(&buffer);
if (objc == 3) {
const char *name = TclGetString(objv[2]);
if ((name[0] == ':') && (name[1] == ':')) {
pattern = name;
} else {
Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
if (nsPtr != globalNsPtr) {
TclDStringAppendLiteral(&buffer, "::");
}
Tcl_DStringAppend(&buffer, name, -1);
|
| ︙ | ︙ | |||
3066 3067 3068 3069 3070 3071 3072 |
listPtr = Tcl_NewListObj(0, NULL);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
size_t length = strlen(nsPtr->fullName);
if (strncmp(pattern, nsPtr->fullName, length) != 0) {
goto searchDone;
}
| < > | > | < < < < < | < | < < < < < < | < | > | 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 |
listPtr = Tcl_NewListObj(0, NULL);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
size_t length = strlen(nsPtr->fullName);
if (strncmp(pattern, nsPtr->fullName, length) != 0) {
goto searchDone;
}
/*
* Global namespace members are prefixed with "::", others not. Ticket [63449c0514]
*/
if (FindChildEntry(nsPtr, (nsPtr != globalNsPtr ? 2 : 0) + pattern+length) != NULL) {
Tcl_ListObjAppendElement(NULL, listPtr,
Tcl_NewStringObj(pattern, -1));
}
goto searchDone;
}
entryPtr = FirstChildEntry(nsPtr, &search);
while (entryPtr != NULL) {
childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
if ((pattern == NULL)
|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
Tcl_ListObjAppendElement(NULL, listPtr,
TclNewNamespaceObj((Tcl_Namespace *) childNsPtr));
}
entryPtr = Tcl_NextHashEntry(&search);
}
searchDone:
Tcl_SetObjResult(interp, listPtr);
Tcl_DStringFree(&buffer);
|
| ︙ | ︙ | |||
3138 3139 3140 3141 3142 3143 3144 |
static int
NamespaceCodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| < | | < < < < | < | | | | | | 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 |
static int
NamespaceCodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr, *objPtr;
const char *arg;
Tcl_Size length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg");
return TCL_ERROR;
}
/*
* If "arg" is already a scoped value, then return it directly.
* Take care to only check for scoping in precisely the style that
* [::namespace code] generates it. Anything more forgiving can have
* the effect of failing in namespaces that contain their own custom
" "namespace" command. [Bug 3202171].
*/
arg = TclGetStringFromObj(objv[1], &length);
if (*arg==':' && length > 20
&& strncmp(arg, "::namespace inscope ", 20) == 0) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
/*
* Otherwise, construct a scoped command by building a list with
* "namespace inscope", the full name of the current namespace, and the
* argument "arg". By constructing a list, we ensure that scoped commands
* are interpreted properly when they are executed later, by the
* "namespace inscope" command.
*/
TclNewObj(listPtr);
TclNewLiteralStringObj(objPtr, "::namespace");
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
TclNewLiteralStringObj(objPtr, "inscope");
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
Tcl_ListObjAppendElement(NULL, listPtr,
TclNewNamespaceObj(TclGetCurrentNamespace(interp)));
Tcl_ListObjAppendElement(NULL, listPtr, objv[1]);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3219 3220 3221 3222 3223 3224 3225 |
static int
NamespaceCurrentCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| < < > > < < | < | < | 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 |
static int
NamespaceCurrentCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
/*
* The "real" name of the global namespace ("::") is the null string, but
* we return "::" for it as a convenience to programmers. Note that "" and
* "::" are treated as synonyms by the namespace code so that it is still
* easy to do things like:
*
* namespace [namespace current]::bar { ... }
*
* This behavior is encoded into TclNewNamespaceObj().
*/
Tcl_SetObjResult(interp,
TclNewNamespaceObj(TclGetCurrentNamespace(interp)));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceDeleteCmd --
|
| ︙ | ︙ | |||
3303 3304 3305 3306 3307 3308 3309 |
for (i = 1; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
|| (((Namespace *) namespacePtr)->flags & NS_TEARDOWN)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 |
for (i = 1; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
|| (((Namespace *) namespacePtr)->flags & NS_TEARDOWN)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\" in namespace delete command",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
TclGetString(objv[i]), (char *)NULL);
return TCL_ERROR;
}
}
/*
* Okay, now delete each namespace.
*/
|
| ︙ | ︙ | |||
3354 3355 3356 3357 3358 3359 3360 | * result. * *---------------------------------------------------------------------- */ static int NamespaceEvalCmd( | | | 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 |
* result.
*
*----------------------------------------------------------------------
*/
static int
NamespaceEvalCmd(
void *clientData, /* Arbitrary value passed to cmd. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
objv);
}
|
| ︙ | ︙ | |||
3451 3452 3453 3454 3455 3456 3457 |
static int
NsEval_Callback(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 |
static int
NsEval_Callback(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Namespace *namespacePtr = (Tcl_Namespace *) data[0];
if (result == TCL_ERROR) {
size_t length = strlen(namespacePtr->fullName);
unsigned limit = 200;
int overflow = (length > limit);
char *cmd = (char *) data[1];
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in namespace %s \"%.*s%s\" script line %d)",
cmd,
(overflow ? limit : (unsigned)length), namespacePtr->fullName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
|
| ︙ | ︙ | |||
3573 3574 3575 3576 3577 3578 3579 |
* the namespace's current export pattern list.
*/
if (objc == 1) {
Tcl_Obj *listPtr;
TclNewObj(listPtr);
| | | 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 |
* the namespace's current export pattern list.
*/
if (objc == 1) {
Tcl_Obj *listPtr;
TclNewObj(listPtr);
(void) Tcl_AppendExportList(interp, NULL, listPtr);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
* Process the optional "-clear" argument.
*/
|
| ︙ | ︙ | |||
3739 3740 3741 3742 3743 3744 3745 |
Tcl_HashSearch search;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
Tcl_Obj *listPtr;
TclNewObj(listPtr);
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
| | | | 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 |
Tcl_HashSearch search;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
Tcl_Obj *listPtr;
TclNewObj(listPtr);
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc == DeleteImportedCmd) {
Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
(char *) Tcl_GetHashKey(&nsPtr->cmdTable, hPtr), -1));
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3803 3804 3805 3806 3807 3808 3809 | * Returns a result in the Tcl interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceInscopeCmd( | | < | 3904 3905 3906 3907 3908 3909 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 |
* Returns a result in the Tcl interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceInscopeCmd(
void *clientData, /* Arbitrary value passed to cmd. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
objv);
}
static int
NRNamespaceInscopeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
Tcl_Obj *cmdObjPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3859 3860 3861 3862 3863 3864 3865 |
* of extra arguments to form the command to evaluate.
*/
if (objc == 3) {
cmdObjPtr = objv[2];
} else {
Tcl_Obj *concatObjv[2];
| < < < < < < < < < | | | 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 |
* of extra arguments to form the command to evaluate.
*/
if (objc == 3) {
cmdObjPtr = objv[2];
} else {
Tcl_Obj *concatObjv[2];
concatObjv[0] = objv[2];
concatObjv[1] = Tcl_NewListObj(objc - 3, objv + 3);
cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
Tcl_DecrRefCount(concatObjv[1]); /* We're done with the list object. */
}
TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope",
NULL, NULL);
return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
}
|
| ︙ | ︙ | |||
3934 3935 3936 3937 3938 3939 3940 |
}
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(resultPtr);
Tcl_GetCommandFullName(interp, origCmd, resultPtr);
| | | < < < < < | > > > > > > | | 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 |
}
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(resultPtr);
Tcl_GetCommandFullName(interp, origCmd, resultPtr);
if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES) {
Tcl_DecrRefCount(resultPtr);
goto namespaceOriginError;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
namespaceOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[1]), (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* NamespaceParentCmd --
*
* Invoked to implement the "namespace parent" command that returns the
|
| ︙ | ︙ | |||
3994 3995 3996 3997 3998 3999 4000 |
}
/*
* Report the parent of the specified namespace.
*/
if (nsPtr->parentPtr != NULL) {
| | < | 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 |
}
/*
* Report the parent of the specified namespace.
*/
if (nsPtr->parentPtr != NULL) {
Tcl_SetObjResult(interp, TclNewNamespaceObj(nsPtr->parentPtr));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4055 4056 4057 4058 4059 4060 4061 |
if (objc == 1) {
Tcl_Obj *resultObj;
TclNewObj(resultObj);
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
if (nsPtr->commandPathArray[i].nsPtr != NULL) {
| | | | | | | 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 |
if (objc == 1) {
Tcl_Obj *resultObj;
TclNewObj(resultObj);
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
if (nsPtr->commandPathArray[i].nsPtr != NULL) {
Tcl_ListObjAppendElement(NULL, resultObj, TclNewNamespaceObj(
(Tcl_Namespace *) nsPtr->commandPathArray[i].nsPtr));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
* There is a path given, so parse it into an array of namespace pointers.
*/
if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
namespaceList = (Tcl_Namespace **)
TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc);
for (i = 0; i < nsObjc; i++) {
if (TclGetNamespaceFromObj(interp, nsObjv[i],
&namespaceList[i]) != TCL_OK) {
goto badNamespace;
}
}
|
| ︙ | ︙ | |||
4123 4124 4125 4126 4127 4128 4129 |
void
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
Tcl_Size pathLength, /* Length of pathAry. */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
| | | | 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 |
void
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
Tcl_Size pathLength, /* Length of pathAry. */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
NamespacePathEntry *tmpPathArray = (NamespacePathEntry *)
Tcl_Alloc(sizeof(NamespacePathEntry) * pathLength);
Tcl_Size i;
for (i=0 ; i<pathLength ; i++) {
tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
tmpPathArray[i].creatorNsPtr = nsPtr;
tmpPathArray[i].prevPtr = NULL;
tmpPathArray[i].nextPtr =
|
| ︙ | ︙ | |||
4275 4276 4277 4278 4279 4280 4281 |
/*
* Find the end of the string, then work backward and find the start of
* the last "::" qualifier.
*/
name = TclGetString(objv[1]);
| | | | | 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 |
/*
* Find the end of the string, then work backward and find the start of
* the last "::" qualifier.
*/
name = TclGetString(objv[1]);
for (p = name; p[0] != '\0'; p++) {
/* empty body */
}
while (--p >= name) {
if ((p[0] == ':') && (p > name) && (p[-1] == ':')) {
p -= 2; /* Back up over the :: */
while ((p >= name) && (p[0] == ':')) {
p--; /* Back up over the preceding : */
}
break;
}
}
if (p >= name) {
|
| ︙ | ︙ | |||
4435 4436 4437 4438 4439 4440 4441 |
Namespace *currNsPtr = (Namespace *) nsPtr;
/*
* Ensure that we check for errors *first* before we change anything.
*/
if (handlerPtr != NULL) {
| | | 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 |
Namespace *currNsPtr = (Namespace *) nsPtr;
/*
* Ensure that we check for errors *first* before we change anything.
*/
if (handlerPtr != NULL) {
if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
/*
* Not a list.
*/
return TCL_ERROR;
}
if (lstlen > 0) {
|
| ︙ | ︙ | |||
4533 4534 4535 4536 4537 4538 4539 |
*/
name = TclGetString(objv[1]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
while (--p > name) {
| | | 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 |
*/
name = TclGetString(objv[1]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
while (--p > name) {
if ((p[0] == ':') && (p[-1] == ':')) {
p++; /* Just after the last "::" */
break;
}
}
if (p >= name) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1));
|
| ︙ | ︙ | |||
4719 4720 4721 4722 4723 4724 4725 | * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep( | | | 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 |
* the namespace, it's structure will be freed.
*
*----------------------------------------------------------------------
*/
static void
FreeNsNameInternalRep(
Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
ResolvedNsName *resNamePtr;
NsNameGetInternalRep(objPtr, resNamePtr);
assert(resNamePtr != NULL);
|
| ︙ | ︙ | |||
4766 4767 4768 4769 4770 4771 4772 |
*
*----------------------------------------------------------------------
*/
static void
DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
| | | 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 |
*
*----------------------------------------------------------------------
*/
static void
DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ResolvedNsName *resNamePtr;
NsNameGetInternalRep(srcPtr, resNamePtr);
assert(resNamePtr != NULL);
NsNameSetInternalRep(copyPtr, resNamePtr);
}
|
| ︙ | ︙ | |||
4802 4803 4804 4805 4806 4807 4808 |
*/
static int
SetNsNameFromAny(
Tcl_Interp *interp, /* Points to the namespace in which to resolve
* name. Also used for error reporting if not
* NULL. */
| | | 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 |
*/
static int
SetNsNameFromAny(
Tcl_Interp *interp, /* Points to the namespace in which to resolve
* name. Also used for error reporting if not
* NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
const char *dummy;
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
ResolvedNsName *resNamePtr;
const char *name;
if (interp == NULL) {
|
| ︙ | ︙ | |||
4827 4828 4829 4830 4831 4832 4833 |
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
nsPtr->refCount++;
| | | 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 |
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
nsPtr->refCount++;
resNamePtr = (ResolvedNsName *) Tcl_Alloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
resNamePtr->refCount = 0;
|
| ︙ | ︙ | |||
4887 4888 4889 4890 4891 4892 4893 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
| | > | 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
nPtr->childTablePtr = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
}
return nPtr->childTablePtr;
#endif
}
/*
|
| ︙ | ︙ | |||
4924 4925 4926 4927 4928 4929 4930 |
TclLogCommandInfo(
Tcl_Interp *interp, /* Interpreter in which to log information. */
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
Tcl_Size length, /* Number of bytes in command (< 0 means use
| | < | 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 |
TclLogCommandInfo(
Tcl_Interp *interp, /* Interpreter in which to log information. */
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
Tcl_Size length, /* Number of bytes in command (< 0 means use
* all bytes up to first null byte). */
const unsigned char *pc, /* Current pc of bytecode execution context */
Tcl_Obj **tosPtr) /* Current stack of bytecode execution
* context */
{
const char *p;
Interp *iPtr = (Interp *) interp;
int overflow, limit = 150;
|
| ︙ | ︙ | |||
4975 4976 4977 4978 4979 4980 4981 |
if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
/*
* Should not happen.
*/
return;
} else {
| < | | | 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 |
if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
/*
* Should not happen.
*/
return;
} else {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
VarTrace *tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
if (tracePtr->traceProc != EstablishErrorInfoTraces) {
/*
* The most recent trace set on ::errorInfo is not the one the
* core itself puts on last. This means some other code is
* tracing the variable, and the additional trace(s) might be
* write traces that expect the timing of writes to
|
| ︙ | ︙ | |||
5012 5013 5014 5015 5016 5017 5018 |
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
Tcl_Size len;
iPtr->resetErrorStack = 0;
| | | 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 |
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
Tcl_Size len;
iPtr->resetErrorStack = 0;
TclListObjLength(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
if (pc != NULL) {
|
| ︙ | ︙ | |||
5097 5098 5099 5100 5101 5102 5103 |
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
Tcl_Size len;
iPtr->resetErrorStack = 0;
| | | 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 |
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
Tcl_Size len;
iPtr->resetErrorStack = 0;
TclListObjLength(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
|
| ︙ | ︙ | |||
5141 5142 5143 5144 5145 5146 5147 |
const char *command, /* First character in command that generated
* the error. */
Tcl_Size length) /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
{
TclLogCommandInfo(interp, script, command, length, NULL, NULL);
}
| < | 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 |
const char *command, /* First character in command that generated
* the error. */
Tcl_Size length) /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
{
TclLogCommandInfo(interp, script, command, length, NULL, NULL);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to generic/tclNotify.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 60 |
*/
typedef struct ThreadSpecificData {
Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */
Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */
Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or NULL
* if none. */
Tcl_Mutex queueMutex; /* Mutex to protect access to the previous
| > > | > < | 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 |
*/
typedef struct ThreadSpecificData {
Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */
Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */
Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or NULL
* if none. */
Tcl_Size eventCount; /* Number of entries, but refer to comments in
* Tcl_ServiceEvent(). */
Tcl_Mutex queueMutex; /* Mutex to protect access to the previous
* four fields. */
int serviceMode; /* One of TCL_SERVICE_NONE or
* TCL_SERVICE_ALL. */
int blockTimeSet; /* 0 means there is no maximum block time:
* block forever. */
Tcl_Time blockTime; /* If blockTimeSet is 1, gives the maximum
* elapsed time for the next block. */
int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called
* during an event source traversal. */
int initialized; /* 1 if notifier has been initialized. */
EventSource *firstEventSourcePtr;
/* Pointer to first event source in list of
* event sources for this thread. */
Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */
void *clientData; /* Opaque handle for platform specific
* notifier. */
struct ThreadSpecificData *nextPtr;
/* Next notifier in global list of notifiers.
* Access is controlled by the listLock global
* mutex. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
Tcl_Free(hold);
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
Tcl_FinalizeNotifier(tsdPtr->clientData);
Tcl_MutexFinalize(&(tsdPtr->queueMutex));
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
| > | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
Tcl_Free(hold);
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
tsdPtr->eventCount = 0;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
Tcl_FinalizeNotifier(tsdPtr->clientData);
Tcl_MutexFinalize(&(tsdPtr->queueMutex));
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 |
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
* possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */
{
| | < < | > | 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
* possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */
{
int wasEmpty = 0;
Tcl_MutexLock(&(tsdPtr->queueMutex));
if ((position & 3) == TCL_QUEUE_TAIL) {
/*
* Append the event on the end of the queue.
*/
evPtr->nextPtr = NULL;
if (tsdPtr->firstEventPtr == NULL) {
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 533 |
tsdPtr->markerEventPtr->nextPtr = evPtr;
}
tsdPtr->markerEventPtr = evPtr;
if (evPtr->nextPtr == NULL) {
tsdPtr->lastEventPtr = evPtr;
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
| > > > > | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
tsdPtr->markerEventPtr->nextPtr = evPtr;
}
tsdPtr->markerEventPtr = evPtr;
if (evPtr->nextPtr == NULL) {
tsdPtr->lastEventPtr = evPtr;
}
}
if (position & TCL_QUEUE_ALERT_IF_EMPTY) {
wasEmpty = (tsdPtr->eventCount <= 0);
}
tsdPtr->eventCount++;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return wasEmpty;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteEvents --
*
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
/*
* Delete the event data structure.
*/
hold = evPtr;
evPtr = evPtr->nextPtr;
Tcl_Free(hold);
} else {
/*
* Event is to be retained.
*/
prevPtr = evPtr;
evPtr = evPtr->nextPtr;
| > | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
/*
* Delete the event data structure.
*/
hold = evPtr;
evPtr = evPtr->nextPtr;
Tcl_Free(hold);
tsdPtr->eventCount--;
} else {
/*
* Event is to be retained.
*/
prevPtr = evPtr;
evPtr = evPtr->nextPtr;
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 |
* TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other
* flags defined elsewhere. Events not
* matching this will be skipped for
* processing later. */
{
Tcl_Event *evPtr, *prevPtr;
Tcl_EventProc *proc;
| | > | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
* TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other
* flags defined elsewhere. Events not
* matching this will be skipped for
* processing later. */
{
Tcl_Event *evPtr, *prevPtr;
Tcl_EventProc *proc;
Tcl_Size eventCount;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
/*
* Asynchronous event handlers are considered to be the highest priority
* events, and so must be invoked before we process events on the event
* queue.
*/
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
evPtr->proc = NULL;
/*
* Release the lock before calling the event function. This allows
* other threads to post events if we enter a recursive event loop in
* this thread. Note that we are making the assumption that if the
* proc returns 0, the event is still in the list.
*/
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
result = proc(evPtr, flags);
Tcl_MutexLock(&(tsdPtr->queueMutex));
if (result) {
/*
* The event was processed, so remove it from the queue.
*/
if (tsdPtr->firstEventPtr == evPtr) {
| > > > > > > > > | 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 |
evPtr->proc = NULL;
/*
* Release the lock before calling the event function. This allows
* other threads to post events if we enter a recursive event loop in
* this thread. Note that we are making the assumption that if the
* proc returns 0, the event is still in the list.
*
* The eventCount is remembered and set to zero that the next
* level of Tcl_ServiceEvent() gets an empty condition for the
* Tcl_ThreadQueueEvent() to perform optional wakeups.
* On exit of the next level, the eventCount is readjusted.
*/
eventCount = tsdPtr->eventCount;
tsdPtr->eventCount = 0;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
result = proc(evPtr, flags);
Tcl_MutexLock(&(tsdPtr->queueMutex));
tsdPtr->eventCount += eventCount;
if (result) {
/*
* The event was processed, so remove it from the queue.
*/
if (tsdPtr->firstEventPtr == evPtr) {
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
}
} else {
evPtr = NULL;
}
}
if (evPtr) {
Tcl_Free(evPtr);
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
} else {
/*
* The event wasn't actually handled, so we have to restore the
* proc field to allow the event to be attempted again.
| > | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
}
} else {
evPtr = NULL;
}
}
if (evPtr) {
Tcl_Free(evPtr);
tsdPtr->eventCount--;
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
} else {
/*
* The event wasn't actually handled, so we have to restore the
* proc field to allow the event to be attempted again.
|
| ︙ | ︙ |
Changes to generic/tclOO.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" /* | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
/*
* Commands in oo::define and oo::objdefine.
*/
static const struct {
const char *name;
Tcl_ObjCmdProc *objProc;
int flag;
} defineCmds[] = {
|
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, Namespace *nsPtr, const char *nsNameStr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); | < < | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, Namespace *nsPtr, const char *nsNameStr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); static void DeletedHelpersNamespace(void *clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); static void InitClassSystemRoots(Tcl_Interp *interp, Foundation *fPtr); |
| ︙ | ︙ | |||
116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
DCM("varname", 0, TclOO_Object_VarName),
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
}, clsMethods[] = {
DCM("create", 1, TclOO_Class_Create),
DCM("new", 1, TclOO_Class_New),
DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
};
/*
* And for the oo::class constructor...
*/
static const Tcl_MethodType classConstructor = {
| > > > | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
DCM("varname", 0, TclOO_Object_VarName),
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
}, clsMethods[] = {
DCM("create", 1, TclOO_Class_Create),
DCM("new", 1, TclOO_Class_New),
DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
}, cfgMethods[] = {
DCM("configure", 1, TclOO_Configurable_Configure),
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
};
/*
* And for the oo::class constructor...
*/
static const Tcl_MethodType classConstructor = {
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
{
return GetFoundation(interp);
}
/*
* ----------------------------------------------------------------------
*
* InitFoundation --
*
* Set up the core of the OO core class system. This is a structure
* holding references to the magical bits that need to be known about in
* other places, plus the oo::object and oo::class classes.
*
* ----------------------------------------------------------------------
*/
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > < < | < | < > > > > > | > | | > < < | < < < | < < < | < < | < > | | | < | | < | | | | < | | | > > > > > > > > > > > > > > > > > > > > | 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 |
{
return GetFoundation(interp);
}
/*
* ----------------------------------------------------------------------
*
* CreateCmdInNS --
*
* Create a command in a namespace. Supports setting various
* implementation functions, but not a deletion callback or a clientData;
* it's suitable for use-cases in this file, no more.
*
* ----------------------------------------------------------------------
*/
static inline void
CreateCmdInNS(
Tcl_Interp *interp,
Tcl_Namespace *namespacePtr,
const char *name,
Tcl_ObjCmdProc *cmdProc,
Tcl_ObjCmdProc *nreProc,
CompileProc *compileProc)
{
Command *cmdPtr;
if (cmdProc == NULL && nreProc == NULL) {
Tcl_Panic("must supply at least one implementation function");
}
cmdPtr = (Command *) TclCreateObjCommandInNs(interp, name,
namespacePtr, cmdProc, NULL, NULL);
cmdPtr->nreProc = nreProc;
cmdPtr->compileProc = compileProc;
}
/*
* ----------------------------------------------------------------------
*
* InitFoundation --
*
* Set up the core of the OO core class system. This is a structure
* holding references to the magical bits that need to be known about in
* other places, plus the oo::object and oo::class classes.
*
* ----------------------------------------------------------------------
*/
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr = (ThreadLocalData *)
Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = (Foundation *) Tcl_Alloc(sizeof(Foundation));
Tcl_Namespace *define, *objdef;
Tcl_Obj *namePtr;
size_t i;
/*
* Initialize the structure that holds the OO system core. This is
* attached to the interpreter via an assocData entry; not very efficient,
* but the best we can do without hacking the core more.
*/
memset(fPtr, 0, sizeof(Foundation));
((Interp *) interp)->objectFoundation = fPtr;
fPtr->interp = interp;
fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
define = Tcl_CreateNamespace(interp, "::oo::define", fPtr, NULL);
objdef = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr, NULL);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
fPtr->epoch = 1;
fPtr->tsdPtr = tsdPtr;
TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
TclNewLiteralStringObj(fPtr->myName, "my");
TclNewLiteralStringObj(fPtr->mcdName, "::oo::MixinClassDelegates");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
Tcl_IncrRefCount(fPtr->clonedName);
Tcl_IncrRefCount(fPtr->defineName);
Tcl_IncrRefCount(fPtr->myName);
Tcl_IncrRefCount(fPtr->mcdName);
TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs,
TclOOUnknownDefinition, NULL, NULL);
TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
Tcl_SetNamespaceUnknownHandler(interp, define, namePtr);
Tcl_SetNamespaceUnknownHandler(interp, objdef, namePtr);
Tcl_BounceRefCount(namePtr);
/*
* Create the subcommands in the oo::define and oo::objdefine spaces.
*/
for (i = 0 ; defineCmds[i].name ; i++) {
TclCreateObjCommandInNs(interp, defineCmds[i].name, define,
defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
}
for (i = 0 ; objdefCmds[i].name ; i++) {
TclCreateObjCommandInNs(interp, objdefCmds[i].name, objdef,
objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
}
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
/*
* Create the special objects at the core of the object system.
*/
InitClassSystemRoots(interp, fPtr);
/*
* Basic method declarations for the core classes.
*/
TclOODefineBasicMethods(fPtr->objectCls, objMethods);
TclOODefineBasicMethods(fPtr->classCls, clsMethods);
/*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
*/
TclNewLiteralStringObj(namePtr, "new");
TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
Tcl_BounceRefCount(namePtr);
fPtr->classCls->constructorPtr = (Method *) TclNewMethod(
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
* Create non-object commands and plug ourselves into the Tcl [info]
* ensemble.
*/
CreateCmdInNS(interp, fPtr->helpersNs, "next",
NULL, TclOONextObjCmd, TclCompileObjectNextCmd);
CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd);
CreateCmdInNS(interp, fPtr->helpersNs, "self",
TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd);
CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL);
CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL);
CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL);
TclOOInitInfo(interp);
/*
* Now make the class of slots.
*/
if (TclOODefineSlots(fPtr) != TCL_OK) {
return TCL_ERROR;
}
/*
* Make the configurable class and install its standard defined method.
*/
Tcl_Object cfgCls = Tcl_NewObjectInstance(interp,
(Tcl_Class) fPtr->classCls, "::oo::configuresupport::configurable",
NULL, TCL_INDEX_NONE, NULL, 0);
TclOODefineBasicMethods(((Object *) cfgCls)->classPtr, cfgMethods);
/*
* Don't have handles to these namespaces, so use Tcl_CreateObjCommand.
*/
Tcl_CreateObjCommand(interp,
"::oo::configuresupport::configurableobject::property",
TclOODefinePropertyCmd, (void *) 1, NULL);
Tcl_CreateObjCommand(interp,
"::oo::configuresupport::configurableclass::property",
TclOODefinePropertyCmd, (void *) 0, NULL);
/*
* Evaluate the remaining definitions, which are a compiled-in Tcl script.
*/
return Tcl_EvalEx(interp, tclOOSetupScript, TCL_INDEX_NONE, 0);
}
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
Object fakeObject;
Tcl_Obj *defNsName;
/* Stand up a phony class for bootstrapping. */
fPtr->objectCls = &fakeCls;
/* referenced in TclOOAllocClass to increment the refCount. */
fakeCls.thisPtr = &fakeObject;
| | | | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 |
Object fakeObject;
Tcl_Obj *defNsName;
/* Stand up a phony class for bootstrapping. */
fPtr->objectCls = &fakeCls;
/* referenced in TclOOAllocClass to increment the refCount. */
fakeCls.thisPtr = &fakeObject;
fakeObject.refCount = 0; // Do not increment an uninitialized value.
fPtr->objectCls = TclOOAllocClass(interp,
AllocObject(interp, "object", (Namespace *) fPtr->ooNs, NULL));
// Corresponding TclOODecrRefCount in KillFoundation
AddRef(fPtr->objectCls->thisPtr);
/*
* This is why it is unnecessary in this routine to replace the
* incremented reference count of fPtr->objectCls that was swallowed by
* fakeObject.
*/
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
fPtr->objectCls->flags |= ROOT_OBJECT;
TclNewLiteralStringObj(defNsName, "::oo::objdefine");
fPtr->objectCls->objDefinitionNs = defNsName;
Tcl_IncrRefCount(defNsName);
fPtr->classCls = TclOOAllocClass(interp,
| | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
fPtr->objectCls->flags |= ROOT_OBJECT;
TclNewLiteralStringObj(defNsName, "::oo::objdefine");
fPtr->objectCls->objDefinitionNs = defNsName;
Tcl_IncrRefCount(defNsName);
fPtr->classCls = TclOOAllocClass(interp,
AllocObject(interp, "class", (Namespace *) fPtr->ooNs, NULL));
// Corresponding TclOODecrRefCount in KillFoundation
AddRef(fPtr->classCls->thisPtr);
/*
* Increment reference counts for each reference because these
* relationships can be dynamically changed.
*
* Corresponding TclOODecrRefCount for all incremented refcounts is in
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
* Everything else is careful to prohibit looping.
*/
}
/*
* ----------------------------------------------------------------------
*
| | | < < < < < < < < < < < < < < < < < < | | | > > > > > > > > > > > > | 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 |
* Everything else is careful to prohibit looping.
*/
}
/*
* ----------------------------------------------------------------------
*
* DeletedHelpersNamespace --
*
* Simple helper used to clear fields of the foundation when they no
* longer hold useful information.
*
* ----------------------------------------------------------------------
*/
static void
DeletedHelpersNamespace(
void *clientData)
{
Foundation *fPtr = (Foundation *) clientData;
fPtr->helpersNs = NULL;
}
/*
* ----------------------------------------------------------------------
*
* KillFoundation --
*
* Delete those parts of the OO core that are not deleted automatically
* when the objects and classes themselves are destroyed.
*
* ----------------------------------------------------------------------
*/
static void
KillFoundation(
TCL_UNUSED(void *),
Tcl_Interp *interp) /* The interpreter containing the OO system
* foundation. */
{
Foundation *fPtr = GetFoundation(interp);
TclDecrRefCount(fPtr->unknownMethodNameObj);
TclDecrRefCount(fPtr->constructorName);
TclDecrRefCount(fPtr->destructorName);
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
TclDecrRefCount(fPtr->myName);
TclDecrRefCount(fPtr->mcdName);
TclOODecrRefCount(fPtr->objectCls->thisPtr);
TclOODecrRefCount(fPtr->classCls->thisPtr);
Tcl_Free(fPtr);
/*
* Don't leave the interpreter field pointing to freed data.
*/
((Interp *) interp)->objectFoundation = NULL;
}
/*
* ----------------------------------------------------------------------
*
* AllocObject --
*
* Allocate an object of basic type. Does not splice the object into its
* class's instance list. The caller must set the classPtr on the object
* to either a class or NULL, call TclOOAddToInstances to add the object
* to the class's instance list, and if the object itself is a class, use
* call TclOOAddToSubclasses() to add it to the right class's list of
* subclasses.
*
* Returns:
* Pointer to the object structure created, or NULL if a specific
* namespace was asked for but couldn't be created.
*
* ----------------------------------------------------------------------
*/
static Object *
AllocObject(
Tcl_Interp *interp, /* Interpreter within which to create the
* object. */
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
size_t creationEpoch;
| | | > > > > > > > | | < < | > | 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 |
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
size_t creationEpoch;
oPtr = (Object *) Tcl_Alloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
* Every object has a namespace; make one. Note that this also normally
* computes the creation epoch value for the object, a sequence number
* that is unique to the object (and which allows us to manage method
* caching without comparing pointers).
*
* When creating a namespace, we first check to see if the caller
* specified the name for the namespace. If not, we generate namespace
* names using the epoch until such time as a new namespace is actually
* created.
*/
if (nsNameStr != NULL) {
oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL);
if (oPtr->namespacePtr == NULL) {
/*
* Couldn't make the specific namespace. Report as an error.
* [Bug 154f0982f2]
*/
Tcl_Free(oPtr);
return NULL;
}
creationEpoch = ++fPtr->tsdPtr->nsCount;
goto configNamespace;
}
while (1) {
char objName[10 + TCL_INTEGER_SPACE];
snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u",
++fPtr->tsdPtr->nsCount);
oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
if (oPtr->namespacePtr != NULL) {
creationEpoch = fPtr->tsdPtr->nsCount;
break;
}
/*
|
| ︙ | ︙ | |||
721 722 723 724 725 726 727 |
* Finally, create the object commands and initialize the trace on the
* public command (so that the object structures are deleted when the
* command is deleted).
*/
if (!nameStr) {
nameStr = oPtr->namespacePtr->name;
| | | | > | | 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 |
* Finally, create the object commands and initialize the trace on the
* public command (so that the object structures are deleted when the
* command is deleted).
*/
if (!nameStr) {
nameStr = oPtr->namespacePtr->name;
nsPtr = (Namespace *) oPtr->namespacePtr;
if (nsPtr->parentPtr != NULL) {
nsPtr = nsPtr->parentPtr;
}
}
oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
(Tcl_Namespace *) nsPtr, TclOOPublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
* abstractions, it is faster and we're inside Tcl here so we're allowed.
*/
cmdPtr = (Command *) oPtr->command;
cmdPtr->nreProc = PublicNRObjectCmd;
cmdPtr->tracePtr = tracePtr = (CommandTrace *)
Tcl_Alloc(sizeof(CommandTrace));
tracePtr->traceProc = ObjectRenamedTrace;
tracePtr->clientData = oPtr;
tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
tracePtr->nextPtr = NULL;
tracePtr->refCount = 1;
oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
MyClassDeleted);
return oPtr;
}
/*
* ----------------------------------------------------------------------
*
* SquelchCachedName --
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 | * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ static void MyDeleted( | | | | | | | 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 |
* of those commands when the object itself is deleted.
*
* ----------------------------------------------------------------------
*/
static void
MyDeleted(
void *clientData) /* Reference to the object whose [my] has been
* squelched. */
{
Object *oPtr = (Object *) clientData;
oPtr->myCommand = NULL;
}
static void
MyClassDeleted(
void *clientData)
{
Object *oPtr = (Object *) clientData;
oPtr->myclassCommand = NULL;
}
/*
* ----------------------------------------------------------------------
*
* ObjectRenamedTrace --
*
* This callback is triggered when the object is deleted by any
* mechanism. It runs the destructors and arranges for the actual cleanup
* of the object's namespace, which in turn triggers cleansing of the
* object data structures.
*
* ----------------------------------------------------------------------
*/
static void
ObjectRenamedTrace(
void *clientData, /* The object being deleted. */
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(const char *) /*oldName*/,
TCL_UNUSED(const char *) /*newName*/,
int flags) /* Why was the object deleted? */
{
Object *oPtr = (Object *) clientData;
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
*/
if (flags & TCL_TRACE_RENAME) {
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
Object *oPtr) /* The object representing the class. */
{
FOREACH_HASH_DECLS;
Tcl_Size i;
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
| | | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 |
Object *oPtr) /* The object representing the class. */
{
FOREACH_HASH_DECLS;
Tcl_Size i;
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVariable;
/*
* Sanity check!
*/
if (!Destructing(oPtr)) {
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 |
clsPtr->classChainCache = NULL;
}
/*
* Squelch the property lists.
*/
| < < < < < < | < < < < < < < < < < < | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
clsPtr->classChainCache = NULL;
}
/*
* Squelch the property lists.
*/
TclOOReleasePropertyStorage(&clsPtr->properties);
/*
* Squelch our filter list.
*/
if (clsPtr->filters.num) {
Tcl_Obj *filterObj;
|
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
}
Tcl_Free(clsPtr->superclasses.list);
clsPtr->superclasses.num = 0;
clsPtr->superclasses.list = NULL;
}
FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
TclOODelMethodRef(mPtr);
}
Tcl_DeleteHashTable(&clsPtr->classMethods);
TclOODelMethodRef(clsPtr->constructorPtr);
TclOODelMethodRef(clsPtr->destructorPtr);
FOREACH(variableObj, clsPtr->variables) {
| > > > > | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
}
Tcl_Free(clsPtr->superclasses.list);
clsPtr->superclasses.num = 0;
clsPtr->superclasses.list = NULL;
}
FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
/* instance gets deleted, so if method remains, reset it there */
if (mPtr->refCount > 1 && mPtr->declaringClassPtr == clsPtr) {
mPtr->declaringClassPtr = NULL;
}
TclOODelMethodRef(mPtr);
}
Tcl_DeleteHashTable(&clsPtr->classMethods);
TclOODelMethodRef(clsPtr->constructorPtr);
TclOODelMethodRef(clsPtr->destructorPtr);
FOREACH(variableObj, clsPtr->variables) {
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 | * (interpreter teardown is complex!) * * ---------------------------------------------------------------------- */ static void ObjectNamespaceDeleted( | | | | | | 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 |
* (interpreter teardown is complex!)
*
* ----------------------------------------------------------------------
*/
static void
ObjectNamespaceDeleted(
void *clientData) /* Pointer to the class whose namespace is
* being deleted. */
{
Object *oPtr = (Object *) clientData;
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = fPtr->interp;
Tcl_Size i;
if (Destructing(oPtr)) {
/*
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
* in that case when the destructor is partially deleted before the uses
* of it have gone. [Bug 2949397]
*/
if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
| < < < > > > | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 |
* in that case when the destructor is partially deleted before the uses
* of it have gone. [Bug 2949397]
*/
if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
oPtr->flags |= DESTRUCTOR_CALLED;
if (contextPtr != NULL) {
int result;
Tcl_InterpState state;
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
state = Tcl_SaveInterpState(interp, TCL_OK);
result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
contextPtr, 0, NULL);
if (result != TCL_OK) {
Tcl_BackgroundException(interp, result);
|
| ︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 |
*/
} else {
/*
* The namespace must have been deleted directly. Delete the command
* as well.
*/
| | | | | | 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 |
*/
} else {
/*
* The namespace must have been deleted directly. Delete the command
* as well.
*/
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
if (oPtr->myclassCommand) {
Tcl_DeleteCommandFromToken(interp, oPtr->myclassCommand);
}
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(interp, oPtr->myCommand);
}
/*
* Splice the object out of its context. After this, we must *not* call
* methods on the object.
*/
// TODO: Should this be protected with a !IsRoot() condition?
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
if (oPtr->mixins.num > 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 |
}
if (i) {
Tcl_Free(oPtr->filters.list);
}
if (oPtr->methodsPtr) {
FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
TclOODelMethodRef(mPtr);
}
Tcl_DeleteHashTable(oPtr->methodsPtr);
Tcl_Free(oPtr->methodsPtr);
}
FOREACH(variableObj, oPtr->variables) {
| > > > > | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 |
}
if (i) {
Tcl_Free(oPtr->filters.list);
}
if (oPtr->methodsPtr) {
FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
/* instance gets deleted, so if method remains, reset it there */
if (mPtr->refCount > 1 && mPtr->declaringObjectPtr == oPtr) {
mPtr->declaringObjectPtr = NULL;
}
TclOODelMethodRef(mPtr);
}
Tcl_DeleteHashTable(oPtr->methodsPtr);
Tcl_Free(oPtr->methodsPtr);
}
FOREACH(variableObj, oPtr->variables) {
|
| ︙ | ︙ | |||
1296 1297 1298 1299 1300 1301 1302 |
oPtr->metadataPtr = NULL;
}
/*
* Squelch the property lists.
*/
| < < < < < < | < < < < < < < < < < < | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
oPtr->metadataPtr = NULL;
}
/*
* Squelch the property lists.
*/
TclOOReleasePropertyStorage(&oPtr->properties);
/*
* Because an object can be a class that is an instance of itself, the
* class object's class structure should only be cleaned after most of
* the cleanup on the object is done.
*
* The class of objects needs some special care; if it is deleted (and
|
| ︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 |
TclOOReleaseClassContents(interp, oPtr);
}
/*
* Delete the object structure itself.
*/
| | | 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 |
TclOOReleaseClassContents(interp, oPtr);
}
/*
* Delete the object structure itself.
*/
TclNsDecrRefCount((Namespace *) oPtr->namespacePtr);
oPtr->namespacePtr = NULL;
TclOODecrRefCount(oPtr->selfCls->thisPtr);
oPtr->selfCls = NULL;
TclOODecrRefCount(oPtr);
return;
}
|
| ︙ | ︙ | |||
1385 1386 1387 1388 1389 1390 1391 | * TclOOObjectDestroyed -- * * Returns TCL_OK if an object is entirely deleted, i.e. the destruction * sequence has completed. * * ---------------------------------------------------------------------- */ | > | > > | 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
* TclOOObjectDestroyed --
*
* Returns TCL_OK if an object is entirely deleted, i.e. the destruction
* sequence has completed.
*
* ----------------------------------------------------------------------
*/
int
TclOOObjectDestroyed(
Object *oPtr)
{
return (oPtr->namespacePtr == NULL);
}
/*
* ----------------------------------------------------------------------
*
* TclOORemoveFromInstances --
|
| ︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 |
Class *clsPtr) /* The class to add the instance to. It is
* assumed that the class is not already
* present as an instance in the class. */
{
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
| | > | > | | 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 |
Class *clsPtr) /* The class to add the instance to. It is
* assumed that the class is not already
* present as an instance in the class. */
{
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
clsPtr->instances.list = (Object **)
Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK);
} else {
clsPtr->instances.list = (Object **)
Tcl_Realloc(clsPtr->instances.list,
sizeof(Object *) * clsPtr->instances.size);
}
}
clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
AddRef(oPtr);
}
/*
|
| ︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 |
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
| | > | > | | 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 |
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
superPtr->subclasses.list = (Class **)
Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->subclasses.list = (Class **)
Tcl_Realloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
AddRef(subPtr->thisPtr);
}
/*
|
| ︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 |
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
| | > | > | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 |
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
superPtr->mixinSubs.list = (Class **)
Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->mixinSubs.list = (Class **)
Tcl_Realloc(superPtr->mixinSubs.list,
sizeof(Class *) * superPtr->mixinSubs.size);
}
}
superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
AddRef(subPtr->thisPtr);
}
/*
|
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 |
TclOOAllocClass(
Tcl_Interp *interp, /* Interpreter within which to allocate the
* class. */
Object *useThisObj) /* Object that is to act as the class
* representation. */
{
Foundation *fPtr = GetFoundation(interp);
| | | | 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 |
TclOOAllocClass(
Tcl_Interp *interp, /* Interpreter within which to allocate the
* class. */
Object *useThisObj) /* Object that is to act as the class
* representation. */
{
Foundation *fPtr = GetFoundation(interp);
Class *clsPtr = (Class *) Tcl_Alloc(sizeof(Class));
memset(clsPtr, 0, sizeof(Class));
clsPtr->thisPtr = useThisObj;
/*
* Configure the namespace path for the class's object.
*/
InitClassPath(interp, clsPtr);
/*
* Classes are subclasses of oo::object, i.e. the objects they create are
* objects.
*/
clsPtr->superclasses.num = 1;
clsPtr->superclasses.list = (Class **) Tcl_Alloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
AddRef(fPtr->objectCls->thisPtr);
/*
* Finish connecting the class structure to the object structure.
*/
|
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
| | | | 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
Tcl_Size objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
Tcl_Size skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
Class *classPtr = (Class *) cls;
Object *oPtr;
void *clientData[4];
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
|
| ︙ | ︙ | |||
1779 1780 1781 1782 1783 1784 1785 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
| | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
Tcl_Size objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
Tcl_Size skip, /* Number of arguments to _not_ pass to the
* constructor. */
Tcl_Object *objectPtr) /* Place to write the object reference upon
* successful allocation. */
{
Class *classPtr = (Class *) cls;
CallContext *contextPtr;
Tcl_InterpState state;
|
| ︙ | ︙ | |||
1861 1862 1863 1864 1865 1866 1867 |
*/
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
if (hPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
| | > > > | 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 |
*/
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
if (hPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
OO_ERROR(interp, OVERWRITE_OBJECT);
return NULL;
}
}
/*
* Create the object.
*/
oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
if (oPtr == NULL) {
return NULL;
}
oPtr->selfCls = classPtr;
AddRef(classPtr->thisPtr);
TclOOAddToInstances(oPtr, classPtr);
/*
* Check to see if we're really creating a class. If so, allocate the
* class structure as well.
|
| ︙ | ︙ | |||
1902 1903 1904 1905 1906 1907 1908 |
static int
FinalizeAlloc(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | | | | | 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 |
static int
FinalizeAlloc(
void *data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = (CallContext *) data[0];
Object *oPtr = (Object *) data[1];
Tcl_InterpState state = (Tcl_InterpState) data[2];
Tcl_Object *objectPtr = (Tcl_Object *) data[3];
/*
* Ensure an error if the object was deleted in the constructor. Don't
* want to lose errors by accident. [Bug 2903011]
*/
if (result != TCL_ERROR && Destructing(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object deleted in constructor", TCL_AUTO_LENGTH));
OO_ERROR(interp, STILLBORN);
result = TCL_ERROR;
}
if (result != TCL_OK) {
Tcl_DiscardInterpState(state);
/*
* Take care to not delete a deleted object; that would be bad. [Bug
|
| ︙ | ︙ | |||
1985 1986 1987 1988 1989 1990 1991 |
/*
* Sanity check.
*/
if (IsRootClass(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | | | 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 |
/*
* Sanity check.
*/
if (IsRootClass(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not clone the class of classes", TCL_AUTO_LENGTH));
OO_ERROR(interp, CLONING_CLASS);
return NULL;
}
/*
* Build the instance. Note that this does not run any constructors.
*/
o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
(Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName,
TCL_INDEX_NONE, NULL, 0);
if (o2Ptr == NULL) {
return NULL;
}
/*
* Copy the object-local methods to the new object.
*/
|
| ︙ | ︙ | |||
2126 2127 2128 2129 2130 2131 2132 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
| | > | | | | 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
cls2Ptr->superclasses.list = (Class **)
Tcl_Realloc(cls2Ptr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
} else {
cls2Ptr->superclasses.list = (Class **)
Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num);
}
memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
cls2Ptr->superclasses.num = clsPtr->superclasses.num;
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
|
| ︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 |
Method *mPtr,
Tcl_Obj *namePtr,
Method **m2PtrPtr)
{
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
| | | | | 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 |
Method *mPtr,
Tcl_Obj *namePtr,
Method **m2PtrPtr)
{
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
void *newClientData;
if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
newClientData);
} else {
m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
mPtr->clientData);
}
if (m2PtrPtr != NULL) {
*m2PtrPtr = m2Ptr;
}
return TCL_OK;
|
| ︙ | ︙ | |||
2424 2425 2426 2427 2428 2429 2430 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | > | 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
clsPtr->metadataPtr = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
|
| ︙ | ︙ | |||
2504 2505 2506 2507 2508 2509 2510 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | | 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
oPtr->metadataPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
|
| ︙ | ︙ | |||
2553 2554 2555 2556 2557 2558 2559 |
int
TclOOPublicObjectCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | | | | | | 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 |
int
TclOOPublicObjectCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData, objc, objv);
}
static int
PublicNRObjectCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return TclOOObjectCmdCore((Object *) clientData, interp, objc, objv,
PUBLIC_METHOD, NULL);
}
int
TclOOPrivateObjectCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd, clientData, objc, objv);
}
static int
PrivateNRObjectCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return TclOOObjectCmdCore((Object *) clientData, interp, objc, objv, 0, NULL);
}
int
TclOOInvokeObject(
Tcl_Interp *interp, /* Interpreter for commands, variables,
* results, error reporting, etc. */
Tcl_Object object, /* The object to invoke. */
Tcl_Class startCls, /* Where in the class chain to start the
* invoke from, or NULL to traverse the whole
* chain including filters. */
int publicPrivate, /* Whether this is an invoke from a public
* context (PUBLIC_METHOD), a private context
* (PRIVATE_METHOD), or a *really* private
* context (any other value; conventionally
* 0). */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Array of argument objects. It is assumed
* that the name of the method to invoke will
* be at index 1. */
{
switch (publicPrivate) {
case PUBLIC_METHOD:
return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
|
| ︙ | ︙ | |||
2645 2646 2647 2648 2649 2650 2651 |
static int
MyClassNRObjCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
static int
MyClassNRObjCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
return TCL_ERROR;
}
return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
NULL);
|
| ︙ | ︙ | |||
2671 2672 2673 2674 2675 2676 2677 |
* ----------------------------------------------------------------------
*/
int
TclOOObjectCmdCore(
Object *oPtr, /* The object being invoked. */
Tcl_Interp *interp, /* The interpreter containing the object. */
| | | 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 |
* ----------------------------------------------------------------------
*/
int
TclOOObjectCmdCore(
Object *oPtr, /* The object being invoked. */
Tcl_Interp *interp, /* The interpreter containing the object. */
Tcl_Size objc, /* How many arguments are being passed in. */
Tcl_Obj *const *objv, /* The array of arguments. */
int flags, /* Whether this is an invocation through the
* public or the private command interface. */
Class *startCls) /* Where to start in the call chain, or NULL
* if we are to start at the front with
* filters and the object's methods (which is
* the normal case). */
|
| ︙ | ︙ | |||
2704 2705 2706 2707 2708 2709 2710 |
/*
* Determine if we're in a context that can see the extra, private methods
* in this class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
| | | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 |
/*
* Determine if we're in a context that can see the extra, private methods
* in this class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
CallContext *callerContextPtr = (CallContext *) framePtr->clientData;
Method *callerMethodPtr =
callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
if (callerMethodPtr->declaringObjectPtr) {
callerObjPtr = callerMethodPtr->declaringObjectPtr;
}
if (callerMethodPtr->declaringClassPtr) {
|
| ︙ | ︙ | |||
2751 2752 2753 2754 2755 2756 2757 |
callerClsPtr, methodNamePtr);
TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
" unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
| | | < | | | | 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 |
callerClsPtr, methodNamePtr);
TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
" unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
TclGetString(methodNamePtr), (char *)NULL);
return TCL_ERROR;
}
} else {
/*
* Get the call chain.
*/
noMapping:
contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
callerClsPtr, NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
" unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), (char *)NULL);
return TCL_ERROR;
}
}
/*
* Check to see if we need to apply magical tricks to start part way
* through the call chain.
*/
if (startCls != NULL) {
for (; contextPtr->index < contextPtr->callPtr->numChain;
contextPtr->index++) {
MInvoke *miPtr = &contextPtr->callPtr->chain[contextPtr->index];
if (miPtr->isFilter) {
continue;
}
if (miPtr->mPtr->declaringClassPtr == startCls) {
break;
}
}
if (contextPtr->index >= contextPtr->callPtr->numChain) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no valid method implementation", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), (char *)NULL);
TclOODeleteContext(contextPtr);
return TCL_ERROR;
}
}
/*
* Invoke the call chain, locking the object structure against deletion
|
| ︙ | ︙ | |||
2821 2822 2823 2824 2825 2826 2827 |
int result)
{
/*
* Dispose of the call chain, which drops the lock on the object's
* structure.
*/
| | | 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 |
int result)
{
/*
* Dispose of the call chain, which drops the lock on the object's
* structure.
*/
TclOODeleteContext((CallContext *) data[0]);
return result;
}
/*
* ----------------------------------------------------------------------
*
* Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext --
|
| ︙ | ︙ | |||
2876 2877 2878 2879 2880 2881 2882 |
methodType = "destructor";
} else {
methodType = "method";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
| | | 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 |
methodType = "destructor";
} else {
methodType = "method";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
OO_ERROR(interp, NOTHING_NEXT);
return TCL_ERROR;
}
/*
* Advance to the next method implementation in the chain in the method
* call context while we process the body. However, need to adjust the
* argument-skip control because we're guaranteed to have a single prefix
|
| ︙ | ︙ | |||
2945 2946 2947 2948 2949 2950 2951 |
methodType = "destructor";
} else {
methodType = "method";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
| | | 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 |
methodType = "destructor";
} else {
methodType = "method";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
OO_ERROR(interp, NOTHING_NEXT);
return TCL_ERROR;
}
/*
* Advance to the next method implementation in the chain in the method
* call context while we process the body. However, need to adjust the
* argument-skip control because we're guaranteed to have a single prefix
|
| ︙ | ︙ | |||
2977 2978 2979 2980 2981 2982 2983 |
static int
FinalizeNext(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
| | | 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 |
static int
FinalizeNext(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *) data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
* and want to operate in the outer context again.
*/
contextPtr->index = PTR2INT(data[1]);
|
| ︙ | ︙ | |||
3018 3019 3020 3021 3022 3023 3024 |
}
if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
| | | | 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 |
}
if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
return (Tcl_Object) cmdPtr->objClientData;
notAnObject:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s does not refer to an object", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
(char *)NULL);
return NULL;
}
/*
* ----------------------------------------------------------------------
*
* TclOOIsReachable --
|
| ︙ | ︙ | |||
3134 3135 3136 3137 3138 3139 3140 |
return contextPtr->callPtr->chain[contextPtr->index].isFilter;
}
Tcl_Object
Tcl_ObjectContextObject(
Tcl_ObjectContext context)
{
| | | | | | | | | 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 |
return contextPtr->callPtr->chain[contextPtr->index].isFilter;
}
Tcl_Object
Tcl_ObjectContextObject(
Tcl_ObjectContext context)
{
return (Tcl_Object) ((CallContext *) context)->oPtr;
}
Tcl_Size
Tcl_ObjectContextSkippedArgs(
Tcl_ObjectContext context)
{
return ((CallContext *) context)->skip;
}
Tcl_Namespace *
Tcl_GetObjectNamespace(
Tcl_Object object)
{
return ((Object *) object)->namespacePtr;
}
Tcl_Command
Tcl_GetObjectCommand(
Tcl_Object object)
{
return ((Object *) object)->command;
}
Tcl_Class
Tcl_GetObjectAsClass(
Tcl_Object object)
{
return (Tcl_Class) ((Object *) object)->classPtr;
}
int
Tcl_ObjectDeleted(
Tcl_Object object)
{
return ((Object *) object)->command == NULL;
}
Tcl_Object
Tcl_GetClassAsObject(
Tcl_Class clazz)
{
return (Tcl_Object) ((Class *) clazz)->thisPtr;
}
Tcl_ObjectMapMethodNameProc *
Tcl_ObjectGetMethodNameMapper(
Tcl_Object object)
{
return ((Object *) object)->mapMethodNameProc;
|
| ︙ | ︙ |
Changes to generic/tclOO.decls.
| ︙ | ︙ | |||
229 230 231 232 233 234 235 236 237 238 239 240 241 |
void TclOOObjectSetMixins(Object *oPtr, Tcl_Size numMixins,
Class *const *mixins)
}
declare 15 {
void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr,
Tcl_Size numMixins, Class *const *mixins)
}
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > | 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 |
void TclOOObjectSetMixins(Object *oPtr, Tcl_Size numMixins,
Class *const *mixins)
}
declare 15 {
void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr,
Tcl_Size numMixins, Class *const *mixins)
}
declare 16 {
Tcl_Method TclOOMakeProcInstanceMethod2(Tcl_Interp *interp, Object *oPtr,
int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
const Tcl_MethodType2 *typePtr, void *clientData,
Proc **procPtrPtr)
}
declare 17 {
Tcl_Method TclOOMakeProcMethod2(Tcl_Interp *interp, Class *clsPtr,
int flags, Tcl_Obj *nameObj, const char *namePtr,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType2 *typePtr,
void *clientData, Proc **procPtrPtr)
}
return
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclOO.h.
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | /* * The type of a method implementation. This describes how to call the method * implementation, how to delete it (when the object or class is deleted) and * how to create a clone of it (when the object or class is copied). */ | | | | 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 |
/*
* The type of a method implementation. This describes how to call the method
* implementation, how to delete it (when the object or class is deleted) and
* how to create a clone of it (when the object or class is copied).
*/
typedef struct Tcl_MethodType {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_(1|CURRENT) in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
Tcl_MethodCallProc *callProc;
/* How to invoke this method. */
Tcl_MethodDeleteProc *deleteProc;
/* How to delete this method's type-specific
* 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_MethodType;
#if TCL_MAJOR_VERSION > 8
typedef struct Tcl_MethodType2 {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_2 in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
Tcl_MethodCallProc2 *callProc;
/* How to invoke this method. */
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | #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. */ | | | | > | | | | | > | > > > | | 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 |
#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.
*/
enum TclOOMethodVersion {
TCL_OO_METHOD_VERSION_1 = 1,
TCL_OO_METHOD_VERSION_2 = 2
};
#define TCL_OO_METHOD_VERSION_CURRENT TCL_OO_METHOD_VERSION_1
/*
* Visibility constants for the flags parameter to Tcl_NewMethod and
* Tcl_NewInstanceMethod.
*/
enum TclOOMethodVisibilityFlags {
TCL_OO_METHOD_PUBLIC = 1,
TCL_OO_METHOD_UNEXPORTED = 0,
TCL_OO_METHOD_PRIVATE = 0x20
};
/*
* The type of some object (or class) metadata. This describes how to delete
* the metadata (when the object or class is deleted) and how to create a
* clone of it (when the object or class is copied).
*/
typedef struct Tcl_ObjectMetadataType {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METADATA_VERSION_CURRENT in
* declarations. */
const char *name;
Tcl_ObjectMetadataDeleteProc *deleteProc;
/* How to delete the metadata. This must not
* be NULL. */
Tcl_CloneProc *cloneProc; /* How to copy the metadata, or NULL if the
* type-specific data can be copied
* directly. */
} Tcl_ObjectMetadataType;
/*
* The correct value for the version field of the Tcl_ObjectMetadataType
* structure. This allows new versions of the structure to be introduced
* without breaking binary compatibility.
*/
enum TclOOMetadataVersion {
TCL_OO_METADATA_VERSION_1 = 1
};
#define TCL_OO_METADATA_VERSION_CURRENT TCL_OO_METADATA_VERSION_1
/*
* Include all the public API, generated from tclOO.decls.
*/
#include "tclOODecls.h"
|
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
static int
FinalizeConstruction(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
static int
FinalizeConstruction(
void *data[],
Tcl_Interp *interp,
int result)
{
Object *oPtr = (Object *) data[0];
if (result != TCL_OK) {
return result;
}
Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
return TCL_OK;
}
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Obj **invoke, *nameObj;
size_t skip = Tcl_ObjectContextSkippedArgs(context);
| | < < > > > > | < | | > > > > > > > > | | | 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 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Obj **invoke, *nameObj;
size_t skip = Tcl_ObjectContextSkippedArgs(context);
if ((size_t) objc > skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv,
"?definitionScript?");
return TCL_ERROR;
}
/*
* Make the class definition delegate. This is special; it doesn't reenter
* here (and the class definition delegate doesn't run any constructors).
*
* This needs to be done before consideration of whether to pass the script
* argument to [oo::define]. [Bug 680503]
*/
nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
oPtr->namespacePtr->fullName);
Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
TclGetString(nameObj), NULL, TCL_INDEX_NONE, NULL, 0);
Tcl_BounceRefCount(nameObj);
/*
* If there's nothing else to do, we're done.
*/
if ((size_t) objc == skip) {
return TCL_OK;
}
/*
* Delegate to [oo::define] to do the work.
*/
invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc - 1];
/*
* Must add references or errors in configuration script will cause
* trouble.
*/
Tcl_IncrRefCount(invoke[0]);
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
static int
DecrRefsPostClassConstructor(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | | | 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 |
static int
DecrRefsPostClassConstructor(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **invoke = (Tcl_Obj **) data[0];
Object *oPtr = (Object *) data[1];
Tcl_InterpState saved;
int code;
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
invoke[0] = oPtr->fPtr->mcdName;
invoke[1] = TclOOObjectName(interp, oPtr);
Tcl_IncrRefCount(invoke[0]);
Tcl_IncrRefCount(invoke[1]);
saved = Tcl_SaveInterpState(interp, result);
code = Tcl_EvalObjv(interp, 2, invoke, 0);
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclStackFree(interp, invoke);
if (code != TCL_OK) {
Tcl_DiscardInterpState(saved);
return code;
}
return Tcl_RestoreInterpState(interp, saved);
}
|
| ︙ | ︙ | |||
193 194 195 196 197 198 199 |
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
| | | | | 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 |
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
OO_ERROR(interp, INSTANTIATE_NONCLASS);
return TCL_ERROR;
}
/*
* Check we have the right number of (sensible) arguments.
*/
if (objc < 1 + Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName ?arg ...?");
return TCL_ERROR;
}
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", TCL_AUTO_LENGTH));
OO_ERROR(interp, EMPTY_NAME);
return TCL_ERROR;
}
/*
* Make the object and return its name.
*/
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
| | | | | | | | | 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 |
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
OO_ERROR(interp, INSTANTIATE_NONCLASS);
return TCL_ERROR;
}
/*
* Check we have the right number of (sensible) arguments.
*/
if (objc + 1 < Tcl_ObjectContextSkippedArgs(context) + 3) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", TCL_AUTO_LENGTH));
OO_ERROR(interp, EMPTY_NAME);
return TCL_ERROR;
}
nsName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context) + 1], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"namespace name must not be empty", TCL_AUTO_LENGTH));
OO_ERROR(interp, EMPTY_NAME);
return TCL_ERROR;
}
/*
* Make the object and return its name.
*/
return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
objName, nsName, objc, objv,
Tcl_ObjectContextSkippedArgs(context) + 2,
AddConstructionFinalizer(interp));
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Class_New --
|
| ︙ | ︙ | |||
329 330 331 332 333 334 335 |
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
| | | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
OO_ERROR(interp, INSTANTIATE_NONCLASS);
return TCL_ERROR;
}
/*
* Make the object and return its name.
*/
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *contextPtr;
| | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *contextPtr;
if (objc != (int) Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
oPtr->flags |= DESTRUCTOR_CALLED;
contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 |
static int
AfterNRDestructor(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
static int
AfterNRDestructor(
void *data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = (CallContext *) data[0];
if (contextPtr->oPtr->command) {
Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
}
TclOODeleteContext(contextPtr);
return result;
}
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
CallContext *contextPtr = (CallContext *) context;
Tcl_Object object = Tcl_ObjectContextObject(context);
size_t skip = Tcl_ObjectContextSkippedArgs(context);
CallFrame *framePtr, **framePtrPtr = &framePtr;
Tcl_Obj *scriptPtr;
CmdFrame *invoker;
| | | > | | 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 |
CallContext *contextPtr = (CallContext *) context;
Tcl_Object object = Tcl_ObjectContextObject(context);
size_t skip = Tcl_ObjectContextSkippedArgs(context);
CallFrame *framePtr, **framePtrPtr = &framePtr;
Tcl_Obj *scriptPtr;
CmdFrame *invoker;
if ((size_t) objc < skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
return TCL_ERROR;
}
/*
* Make the object's namespace the current namespace and evaluate the
* command(s).
*/
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
Tcl_GetObjectNamespace(object), FRAME_IS_METHOD);
framePtr->clientData = context;
framePtr->objc = objc;
framePtr->objv = objv; /* Reference counts do not need to be
* incremented here. */
if (!(contextPtr->callPtr->flags & PUBLIC_METHOD)) {
object = NULL; /* Now just for error mesage printing. */
}
/*
* Work out what script we are actually going to evaluate.
*
* When there's more than one argument, we concatenate them together with
* spaces between, then evaluate the result. Tcl_EvalObjEx will delete the
* object when it decrements its refcount after eval'ing it.
*/
if ((size_t) objc != skip+1) {
scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
invoker = NULL;
} else {
scriptPtr = objv[skip];
invoker = ((Interp *) interp)->cmdFramePtr;
}
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
static int
FinalizeEval(
void *data[],
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
| | | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
static int
FinalizeEval(
void *data[],
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
Object *oPtr = (Object *) data[0];
const char *namePtr;
if (oPtr) {
namePtr = TclGetString(TclOOObjectName(interp, oPtr));
} else {
namePtr = "my";
}
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 |
/*
* If no method name, generate an error asking for a method name. (Only by
* overriding *this* method can an object handle the absence of a method
* name without an error).
*/
| | | | 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 |
/*
* If no method name, generate an error asking for a method name. (Only by
* overriding *this* method can an object handle the absence of a method
* name without an error).
*/
if ((size_t) objc < skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
return TCL_ERROR;
}
/*
* Determine if the calling context should know about extra private
* methods, and if so, which.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
CallContext *callerContext = (CallContext *) framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
if (mPtr->declaringObjectPtr) {
if (oPtr == mPtr->declaringObjectPtr) {
callerObj = mPtr->declaringObjectPtr;
}
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
piece = "visible methods";
} else {
piece = "methods";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
| | | | | | | | 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 |
piece = "visible methods";
} else {
piece = "methods";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), (char *)NULL);
return TCL_ERROR;
}
errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
TclGetString(objv[skip]));
for (i=0 ; i<numMethodNames-1 ; i++) {
if (i) {
Tcl_AppendToObj(errorMsg, ", ", TCL_AUTO_LENGTH);
}
Tcl_AppendToObj(errorMsg, methodNames[i], TCL_AUTO_LENGTH);
}
if (i) {
Tcl_AppendToObj(errorMsg, " or ", TCL_AUTO_LENGTH);
}
Tcl_AppendToObj(errorMsg, methodNames[i], TCL_AUTO_LENGTH);
Tcl_Free((void *)methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), (char *)NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Object_LinkVar --
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
* local names.
*/
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable name \"%s\" illegal: must not contain namespace"
" separator", varName));
| | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 |
* local names.
*/
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable name \"%s\" illegal: must not contain namespace"
" separator", varName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (char *)NULL);
return TCL_ERROR;
}
/*
* Switch to the object's namespace for the duration of this call.
* Like this, the variable is looked up in the namespace of the
* object, and not in the namespace of the caller. Otherwise this
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 | /* * Variable cannot be an element in an array. If aryPtr is not * NULL, it is an element, so throw up an error and return. */ TclVarErrMsg(interp, varName, NULL, "define", "name refers to an element in an array"); | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 | /* * Variable cannot be an element in an array. If aryPtr is not * NULL, it is an element, so throw up an error and return. */ TclVarErrMsg(interp, varName, NULL, "define", "name refers to an element in an array"); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (char *)NULL); return TCL_ERROR; } /* * Arrange for the lifetime of the variable to be correctly managed. * This is copied out of Tcl_VariableObjCmd... */ |
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
| | | > > > | < | < | < | | > > > | < < < | < < < | < < < < | | | | | | | | | | | | | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < | < | < | | 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 |
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOLookupObjectVar --
*
* Look up a variable in an object. Tricky because of private variables.
*
* Returns:
* Handle to the variable if it can be found, or NULL if there's an error.
*
* ----------------------------------------------------------------------
*/
Tcl_Var
TclOOLookupObjectVar(
Tcl_Interp *interp,
Tcl_Object object, /* Object we're looking up within. */
Tcl_Obj *varName, /* User-visible name we're looking up. */
Tcl_Var *aryPtr) /* Where to write the handle to the array
* containing the element; if not an element,
* then the variable this points to is set to
* NULL. */
{
const char *arg = TclGetString(varName);
Tcl_Obj *varNamePtr;
/*
* Convert the variable name to fully-qualified form if it wasn't already.
* This has to be done prior to lookup because we can run into problems
* with resolvers otherwise. [Bug 3603695]
*
* We still need to do the lookup; the variable could be linked to another
* variable and we want the target's name.
*/
if (arg[0] == ':' && arg[1] == ':') {
varNamePtr = varName;
} else {
Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(object);
CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
/*
* Private method handling. [TIP 500]
*
* If we're in a context that can see some private methods of an
* object, we may need to precede a variable name with its prefix.
* This is a little tricky as we need to check through the inheritance
* hierarchy when the method was declared by a class to see if the
* current object is an instance of that class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
Object *oPtr = (Object *) object;
CallContext *callerContext = (CallContext *) framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
PrivateVariableMapping *pvPtr;
Tcl_Size i;
if (mPtr->declaringObjectPtr == oPtr) {
FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
TCL_INDEX_NONE)) {
varName = pvPtr->fullNameObj;
break;
}
}
} else if (mPtr->declaringClassPtr &&
mPtr->declaringClassPtr->privateVariables.num) {
Class *clsPtr = mPtr->declaringClassPtr;
int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
Class *mixinCls;
if (!isInstance) {
FOREACH(mixinCls, oPtr->mixins) {
if (TclOOIsReachable(clsPtr, mixinCls)) {
isInstance = 1;
break;
}
}
}
if (isInstance) {
FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
TCL_INDEX_NONE)) {
varName = pvPtr->fullNameObj;
break;
}
}
}
}
}
// The namespace isn't the global one; necessarily true for any object!
varNamePtr = Tcl_ObjPrintf("%s::%s",
namespacePtr->fullName, TclGetString(varName));
}
Tcl_IncrRefCount(varNamePtr);
Tcl_Var var = (Tcl_Var) TclObjLookupVar(interp, varNamePtr, NULL,
TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1,
(Var **) aryPtr);
Tcl_DecrRefCount(varNamePtr);
if (var == NULL) {
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *) NULL);
} else if (*aryPtr == NULL && TclIsVarArrayElement((Var *) var)) {
/*
* If the varPtr points to an element of an array but we don't already
* have the array, find it now. Note that this can't be easily
* backported; the arrayPtr field is new in Tcl 9.0. [Bug 2da1cb0c80]
*/
*aryPtr = (Tcl_Var) TclVarParentArray(var);
}
return var;
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Object_VarName --
*
* Implementation of the oo::object->varname method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_VarName(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Tcl_Var varPtr, aryVar;
Tcl_Obj *varNamePtr;
if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
objv[objc - 1], &aryVar);
if (varPtr == NULL) {
return TCL_ERROR;
}
/*
* The variable reference must not disappear too soon. [Bug 74b6110204]
*/
if (!TclIsVarArrayElement((Var *) varPtr)) {
TclSetVarNamespaceVar((Var *) varPtr);
}
/*
* Now that we've pinned down what variable we're really talking about
* (including traversing variable links), convert back to a name.
*/
TclNewObj(varNamePtr);
if (aryVar != NULL) {
Tcl_GetVariableFullName(interp, aryVar, varNamePtr);
Tcl_AppendPrintfToObj(varNamePtr, "(%s)", Tcl_GetString(
VarHashGetKey(varPtr)));
} else {
Tcl_GetVariableFullName(interp, varPtr, varNamePtr);
}
Tcl_SetObjResult(interp, varNamePtr);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
| | | | 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
OO_ERROR(interp, CONTEXT_REQUIRED);
return TCL_ERROR;
}
context = (Tcl_ObjectContext) framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
* that this is like [uplevel 1] and not [eval].
*/
TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
| | | | | | | | | < | | | | 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 |
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
OO_ERROR(interp, CONTEXT_REQUIRED);
return TCL_ERROR;
}
contextPtr = (CallContext *) framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
return TCL_ERROR;
}
object = Tcl_GetObjectFromObj(interp, objv[1]);
if (object == NULL) {
return TCL_ERROR;
}
classPtr = ((Object *) object)->classPtr;
if (classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[1])));
OO_ERROR(interp, CLASS_REQUIRED);
return TCL_ERROR;
}
/*
* Search for an implementation of a method associated with the current
* call on the call chain past the point where we currently are. Do not
* allow jumping backwards!
*/
for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
MInvoke *miPtr = &contextPtr->callPtr->chain[i];
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
/*
* Invoke the (advanced) method call context in the caller
* context. Note that this is like [uplevel 1] and not [eval].
*/
TclNRAddCallback(interp, NextRestoreFrame, framePtr,
contextPtr, INT2PTR(contextPtr->index), NULL);
contextPtr->index = i - 1;
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp,
(Tcl_ObjectContext) contextPtr, objc, objv, 2);
}
}
/*
* Generate an appropriate error message, depending on whether the value
* is on the chain but unreachable, or not on the chain at all.
*/
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
methodType = "constructor";
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
methodType = "destructor";
} else {
methodType = "method";
}
for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
MInvoke *miPtr = &contextPtr->callPtr->chain[i];
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s implementation by \"%s\" not reachable from here",
methodType, TclGetString(objv[1])));
OO_ERROR(interp, CLASS_NOT_REACHABLE);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s has no non-filter implementation by \"%s\"",
methodType, TclGetString(objv[1])));
OO_ERROR(interp, CLASS_NOT_THERE);
return TCL_ERROR;
}
static int
NextRestoreFrame(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallContext *contextPtr = (CallContext *) data[1];
iPtr->varFramePtr = (CallFrame *) data[0];
if (contextPtr != NULL) {
contextPtr->index = PTR2UINT(data[2]);
}
return result;
}
/*
|
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 |
* Start with sanity checks on the calling context and the method context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
| | | | 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 |
* Start with sanity checks on the calling context and the method context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
OO_ERROR(interp, CONTEXT_REQUIRED);
return TCL_ERROR;
}
contextPtr = (CallContext *) framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
* subcommand takes arguments.
*/
if (objc > 2) {
|
| ︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 |
}
switch (index) {
case SELF_OBJECT:
Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
return TCL_OK;
case SELF_NS:
| | | | | | | | | | | | > | | | | | | | | | 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 |
}
switch (index) {
case SELF_OBJECT:
Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
return TCL_OK;
case SELF_NS:
Tcl_SetObjResult(interp,
TclNewNamespaceObj(contextPtr->oPtr->namespacePtr));
return TCL_OK;
case SELF_CLASS: {
Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
if (clsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method not defined by a class", TCL_AUTO_LENGTH));
OO_ERROR(interp, UNMATCHED_CONTEXT);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
return TCL_OK;
}
case SELF_METHOD:
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
} else {
Tcl_SetObjResult(interp,
CurrentlyInvoked(contextPtr).mPtr->namePtr);
}
return TCL_OK;
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", TCL_AUTO_LENGTH));
OO_ERROR(interp, UNMATCHED_CONTEXT);
return TCL_ERROR;
} else {
MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
Object *oPtr;
const char *type;
if (miPtr->filterDeclarer != NULL) {
oPtr = miPtr->filterDeclarer->thisPtr;
type = "class";
} else {
oPtr = contextPtr->oPtr;
type = "object";
}
result[0] = TclOOObjectName(interp, oPtr);
result[1] = Tcl_NewStringObj(type, TCL_AUTO_LENGTH);
result[2] = miPtr->mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
return TCL_OK;
}
case SELF_CALLER:
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", TCL_AUTO_LENGTH));
OO_ERROR(interp, CONTEXT_REQUIRED);
return TCL_ERROR;
} else {
CallContext *callerPtr = (CallContext *)
framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = TclOOObjectName(interp, callerPtr->oPtr);
if (callerPtr->callPtr->flags & CONSTRUCTOR) {
result[2] = declarerPtr->fPtr->constructorName;
} else if (callerPtr->callPtr->flags & DESTRUCTOR) {
result[2] = declarerPtr->fPtr->destructorName;
} else {
result[2] = mPtr->namePtr;
}
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
return TCL_OK;
}
case SELF_NEXT:
if (contextPtr->index < contextPtr->callPtr->numChain - 1) {
Method *mPtr =
contextPtr->callPtr->chain[contextPtr->index + 1].mPtr;
Object *declarerPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
result[1] = declarerPtr->fPtr->constructorName;
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
result[1] = declarerPtr->fPtr->destructorName;
} else {
result[1] = mPtr->namePtr;
}
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
}
return TCL_OK;
case SELF_TARGET:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", TCL_AUTO_LENGTH));
OO_ERROR(interp, UNMATCHED_CONTEXT);
return TCL_ERROR;
} else {
Method *mPtr;
Object *declarerPtr;
Tcl_Size i;
for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++) {
if (!contextPtr->callPtr->chain[i].isFilter) {
break;
}
}
if (i == contextPtr->callPtr->numChain) {
Tcl_Panic("filtering call chain without terminal non-filter");
}
mPtr = contextPtr->callPtr->chain[i].mPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1277 1278 1279 1280 1281 1282 1283 |
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr, o2Ptr;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
| | | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 |
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr, o2Ptr;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"sourceName ?targetName? ?targetNamespace?");
return TCL_ERROR;
}
oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" #include <assert.h> /* | | | < | | | | | | | | | | | | | | > > | 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 |
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include <assert.h>
/*
* Structure containing a CallChain and any other values needed only during
* the construction of the CallChain.
*/
typedef struct ChainBuilder {
CallChain *callChainPtr; /* The call chain being built. */
size_t filterLength; /* Number of entries in the call chain that
* are due to processing filters and not the
* main call chain. */
Object *oPtr; /* The object that we are building the chain
* for. */
} ChainBuilder;
/*
* Structures used for traversing the class hierarchy to find out where
* definitions are supposed to be done.
*/
typedef struct DefineEntry {
Class *definerCls;
Tcl_Obj *namespaceName;
} DefineEntry;
typedef struct DefineChain {
DefineEntry *list;
int num;
int size;
} DefineChain;
/*
* Extra flags used for call chain management.
*/
enum CallChainFlags {
DEFINITE_PROTECTED = 0x100000,
DEFINITE_PUBLIC = 0x200000,
KNOWN_STATE = (DEFINITE_PROTECTED | DEFINITE_PUBLIC),
SPECIAL = (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN),
BUILDING_MIXINS = 0x400000,
TRAVERSED_MIXIN = 0x800000,
OBJECT_MIXIN = 0x1000000,
DEFINE_FOR_CLASS = 0x2000000
};
#define MIXIN_CONSISTENT(flags) \
(((flags) & OBJECT_MIXIN) || \
!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
/*
* Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
* Itcl's special type of private.
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 89 90 91 92 93 |
#define WANT_UNEXPORTED(flags) \
(((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
#define WANT_ITCLPRIVATE(flags) \
(((flags) & PRIVATE_METHOD) != 0)
#define WANT_PRIVATE(flags) \
(((flags) & TRUE_PRIVATE_METHOD) != 0)
/*
* Function declarations for things defined in this file.
*/
static void AddClassFiltersToCallContext(Object *const oPtr,
| > > > > > > > > | | | | | | | 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 |
#define WANT_UNEXPORTED(flags) \
(((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
#define WANT_ITCLPRIVATE(flags) \
(((flags) & PRIVATE_METHOD) != 0)
#define WANT_PRIVATE(flags) \
(((flags) & TRUE_PRIVATE_METHOD) != 0)
/*
* Name the bits used in the names table values.
*/
enum NameTableValues {
IN_LIST = 1, /* Seen an implementation. */
NO_IMPLEMENTATION = 2 /* Seen, but not implemented yet. */
};
/*
* Function declarations for things defined in this file.
*/
static void AddClassFiltersToCallContext(Object *const oPtr,
Class *clsPtr, ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags);
static void AddClassMethodNames(Class *clsPtr, int flags,
Tcl_HashTable *const namesPtr,
Tcl_HashTable *const examinedClassesPtr);
static inline void AddDefinitionNamespaceToChain(Class *const definerCls,
Tcl_Obj *const namespaceName,
DefineChain *const definePtr, int flags);
static inline void AddMethodToCallChain(Method *const mPtr,
ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters,
Class *const filterDecl, int flags);
static inline int AddInstancePrivateToCallContext(Object *const oPtr,
Tcl_Obj *const methodNameObj,
ChainBuilder *const cbPtr, int flags);
static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr,
Method *mPtr, Tcl_HashTable *namesPtr);
static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
Tcl_HashTable *namesPtr);
static inline int AddSimpleChainToCallContext(Object *const oPtr,
Class *const contextCls,
Tcl_Obj *const methodNameObj,
ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
static int AddPrivatesFromClassChainToCallContext(Class *classPtr,
Class *const contextCls,
Tcl_Obj *const methodNameObj,
ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
static int AddSimpleClassChainToCallContext(Class *classPtr,
Tcl_Obj *const methodNameObj,
ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
static void AddSimpleClassDefineNamespaces(Class *classPtr,
DefineChain *const definePtr, int flags);
static inline void AddSimpleDefineNamespaces(Object *const oPtr,
DefineChain *const definePtr, int flags);
static int CmpStr(const void *ptr1, const void *ptr2);
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
"TclOO method name",
FreeMethodNameRep,
DupMethodNameRep,
NULL,
NULL,
TCL_OBJTYPE_V0
};
| < | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
"TclOO method name",
FreeMethodNameRep,
DupMethodNameRep,
NULL,
NULL,
TCL_OBJTYPE_V0
};
/*
* ----------------------------------------------------------------------
*
* TclOODeleteContext --
*
* Destroys a method call-chain context, which should not be in use.
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
*/
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
| | | | | | | | 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 |
*/
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
StashCallChain(dstPtr, (CallChain *)
TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
TclOODeleteChain((CallChain *)
TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
* ----------------------------------------------------------------------
*
* TclOOInvokeContext --
*
* Invokes a single step along a method call-chain context. Note that the
* invocation of a step along the chain can cause further steps along the
* chain to be invoked. Note that this function is written to be as light
* in stack usage as possible.
*
* ----------------------------------------------------------------------
*/
int
TclOOInvokeContext(
void *clientData, /* The method call context. */
Tcl_Interp *interp, /* Interpreter for error reporting, and many
* other sorts of context handling (e.g.,
* commands, variables) depending on method
* implementation. */
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The arguments as actually seen. */
{
CallContext *const contextPtr = (CallContext *) clientData;
Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const int isFilter =
contextPtr->callPtr->chain[contextPtr->index].isFilter;
/*
* If this is the first step along the chain, we preserve the method
* entries in the chain so that they do not get deleted out from under our
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
* Run the method implementation.
*/
if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
| | | | | | 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 |
* Run the method implementation.
*/
if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
return (mPtr->type2Ptr->callProc)(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *) data[0];
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
}
static int
ResetFilterFlags(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *) data[0];
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
}
static int
FinalizeMethodRefs(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *) data[0];
Tcl_Size i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
}
return result;
}
|
| ︙ | ︙ | |||
456 457 458 459 460 461 462 |
Class *mixinPtr;
Tcl_Obj *namePtr;
Method *mPtr;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
| < < < < < < | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
Class *mixinPtr;
Tcl_Obj *namePtr;
Method *mPtr;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
/*
* Process method names due to the object.
*/
if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
if (IS_PRIVATE(mPtr)) {
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 |
/*
* We need to build the list of methods to sort. We will be using qsort()
* for this, because it is very unlikely that the list will be heavily
* sorted when it is long enough to matter.
*/
| | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
/*
* We need to build the list of methods to sort. We will be using qsort()
* for this, because it is very unlikely that the list will be heavily
* sorted when it is long enough to matter.
*/
strings = (const char **) Tcl_Alloc(sizeof(char *) * namesPtr->numEntries);
FOREACH_HASH(namePtr, isWanted, namesPtr) {
if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) {
if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
continue;
}
strings[i++] = TclGetString(namePtr);
}
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
*
* ----------------------------------------------------------------------
*/
static void
AddClassMethodNames(
Class *clsPtr, /* Class to get method names from. */
| | | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
*
* ----------------------------------------------------------------------
*/
static void
AddClassMethodNames(
Class *clsPtr, /* Class to get method names from. */
int flags, /* Whether we are interested in just the
* public method names. */
Tcl_HashTable *const namesPtr,
/* Reference to the hash table to put the
* information in. The hash table maps the
* Tcl_Obj * method name to an integral value
* describing whether the method is wanted.
* This ensures that public/private override
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
isWanted &= ~NO_IMPLEMENTATION;
Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
}
}
}
| < < < < | | | 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 |
int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
isWanted &= ~NO_IMPLEMENTATION;
Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
}
}
}
/*
* ----------------------------------------------------------------------
*
* AddInstancePrivateToCallContext --
*
* Add private methods from the instance. Called when the calling Tcl
* context is a TclOO method declared by an object that is the same as
* the current object. Returns true iff a private method was actually
* found and added to the call chain (as this suppresses caching).
*
* ----------------------------------------------------------------------
*/
static inline int
AddInstancePrivateToCallContext(
Object *const oPtr, /* Object to add call chain entries for. */
Tcl_Obj *const methodName, /* Name of method to add the call chain
* entries for. */
ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
int flags) /* What sort of call chain are we building. */
{
Tcl_HashEntry *hPtr;
Method *mPtr;
int donePrivate = 0;
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName);
if (hPtr != NULL) {
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
donePrivate = 1;
}
}
}
return donePrivate;
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
Object *const oPtr, /* Object to add call chain entries for. */
Class *const contextCls, /* Context class; the currently considered
* class is equal to this, private methods may
* also be added. [TIP 500] */
Tcl_Obj *const methodNameObj,
/* Name of method to add the call chain
* entries for. */
| < | | | 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 |
Object *const oPtr, /* Object to add call chain entries for. */
Class *const contextCls, /* Context class; the currently considered
* class is equal to this, private methods may
* also be added. [TIP 500] */
Tcl_Obj *const methodNameObj,
/* Name of method to add the call chain
* entries for. */
ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
Tcl_Size i;
int foundPrivate = 0, blockedUnexported = 0;
Tcl_HashEntry *hPtr;
Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
if (WANT_PUBLIC(flags)) {
if (!IS_PUBLIC(mPtr)) {
blockedUnexported = 1;
} else {
flags |= DEFINITE_PUBLIC;
}
|
| ︙ | ︙ | |||
919 920 921 922 923 924 925 |
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
if (hPtr != NULL) {
| | > > > | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 |
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
}
}
}
}
if (!oPtr->selfCls) {
return foundPrivate;
}
if (contextCls) {
foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls,
contextCls, methodNameObj, cbPtr, doneFilters, flags,
filterDecl);
}
if (!blockedUnexported) {
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 |
* ----------------------------------------------------------------------
*/
static inline void
AddMethodToCallChain(
Method *const mPtr, /* Actual method implementation to add to call
* chain (or NULL, a no-op). */
| < | | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
* ----------------------------------------------------------------------
*/
static inline void
AddMethodToCallChain(
Method *const mPtr, /* Actual method implementation to add to call
* chain (or NULL, a no-op). */
ChainBuilder *const cbPtr, /* The call chain to add the method
* implementation to. */
Tcl_HashTable *const doneFilters,
/* Where to record what filters have been
* processed. If NULL, not processing filters.
* Note that this function does not update
* this hashtable. */
Class *const filterDecl, /* The class that declared the filter. If
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
/*
* Need to really add the method. This is made a bit more complex by the
* fact that we are using some "static" space initially, and only start
* realloc-ing if the chain gets long.
*/
if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
| | | | | | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
/*
* Need to really add the method. This is made a bit more complex by the
* fact that we are using some "static" space initially, and only start
* realloc-ing if the chain gets long.
*/
if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
callPtr->chain = (MInvoke *)
Tcl_Alloc(sizeof(MInvoke) * (callPtr->numChain + 1));
memcpy(callPtr->chain, callPtr->staticChain,
sizeof(MInvoke) * callPtr->numChain);
} else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
callPtr->chain = (MInvoke *) Tcl_Realloc(callPtr->chain,
sizeof(MInvoke) * (callPtr->numChain + 1));
}
callPtr->chain[i].mPtr = mPtr;
callPtr->chain[i].isFilter = (doneFilters != NULL);
callPtr->chain[i].filterDeclarer = filterDecl;
callPtr->numChain++;
}
|
| ︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 |
static inline void
InitCallChain(
CallChain *callPtr,
Object *oPtr,
int flags)
{
callPtr->flags = flags &
(PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING);
if (oPtr->flags & USE_CLASS_CACHE) {
| > > > > > > > | > | | | > > > > > | 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 |
static inline void
InitCallChain(
CallChain *callPtr,
Object *oPtr,
int flags)
{
/*
* Note that it's possible to end up with a NULL oPtr->selfCls here if
* there is a call into stereotypical object after it has finished running
* its destructor phase. Such things can't be cached for a long time so the
* epoch can be bogus. [Bug 7842f33a5c]
*/
callPtr->flags = flags &
(PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING);
if (oPtr->flags & USE_CLASS_CACHE) {
oPtr = (oPtr->selfCls ? oPtr->selfCls->thisPtr : NULL);
callPtr->flags |= USE_CLASS_CACHE;
}
if (oPtr) {
callPtr->epoch = oPtr->fPtr->epoch;
callPtr->objectCreationEpoch = oPtr->creationEpoch;
callPtr->objectEpoch = oPtr->epoch;
} else {
callPtr->epoch = 0;
callPtr->objectCreationEpoch = 0;
callPtr->objectEpoch = 0;
}
callPtr->refCount = 1;
callPtr->numChain = 0;
callPtr->chain = callPtr->staticChain;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 |
IsStillValid(
CallChain *callPtr,
Object *oPtr,
int flags,
int mask)
{
if ((oPtr->flags & USE_CLASS_CACHE)) {
oPtr = oPtr->selfCls->thisPtr;
flags |= USE_CLASS_CACHE;
}
return ((callPtr->objectCreationEpoch == oPtr->creationEpoch)
&& (callPtr->epoch == oPtr->fPtr->epoch)
&& (callPtr->objectEpoch == oPtr->epoch)
&& ((callPtr->flags & mask) == (flags & mask)));
| > > > > > > > | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 |
IsStillValid(
CallChain *callPtr,
Object *oPtr,
int flags,
int mask)
{
if ((oPtr->flags & USE_CLASS_CACHE)) {
/*
* If the object is in a weird state (due to stereotype tricks) then
* just declare the cache invalid. [Bug 7842f33a5c]
*/
if (!oPtr->selfCls) {
return 0;
}
oPtr = oPtr->selfCls->thisPtr;
flags |= USE_CLASS_CACHE;
}
return ((callPtr->objectCreationEpoch == oPtr->creationEpoch)
&& (callPtr->epoch == oPtr->fPtr->epoch)
&& (callPtr->objectEpoch == oPtr->epoch)
&& ((callPtr->flags & mask) == (flags & mask)));
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 |
* also be added. [TIP 500] */
Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
* to be in the same object as the
* methodNameObj. */
{
CallContext *contextPtr;
CallChain *callPtr;
| | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 |
* also be added. [TIP 500] */
Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
* to be in the same object as the
* methodNameObj. */
{
CallContext *contextPtr;
CallChain *callPtr;
ChainBuilder cb;
Tcl_Size i, count;
int doFilters, donePrivate = 0;
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
if (cacheInThisObj == NULL) {
cacheInThisObj = methodNameObj;
|
| ︙ | ︙ | |||
1198 1199 1200 1201 1202 1203 1204 |
* the object, and in the class).
*/
const Tcl_ObjInternalRep *irPtr;
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) {
| | > > > > > > > > | | | | | 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 |
* the object, and in the class).
*/
const Tcl_ObjInternalRep *irPtr;
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) {
callPtr = (CallChain *) irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL);
}
/*
* Note that it's possible to end up with a NULL oPtr->selfCls here if
* there is a call into stereotypical object after it has finished
* running its destructor phase. It's quite a tangle, but at that
* point, we simply can't get stereotypes from the cache.
* [Bug 7842f33a5c]
*/
if (oPtr->flags & USE_CLASS_CACHE && oPtr->selfCls) {
if (oPtr->selfCls->classChainCache) {
hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
methodNameObj);
} else {
hPtr = NULL;
}
} else {
if (oPtr->chainCache != NULL) {
hPtr = Tcl_FindHashEntry(oPtr->chainCache,
methodNameObj);
} else {
hPtr = NULL;
}
}
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
callPtr = (CallChain *) Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
doFilters = 1;
}
callPtr = (CallChain *) Tcl_Alloc(sizeof(CallChain));
InitCallChain(callPtr, oPtr, flags);
cb.callChainPtr = callPtr;
cb.filterLength = 0;
cb.oPtr = oPtr;
/*
|
| ︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 |
return NULL;
}
} else if (doFilters && !donePrivate) {
if (hPtr == NULL) {
int isNew;
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
| | | | > | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 |
return NULL;
}
} else if (doFilters && !donePrivate) {
if (hPtr == NULL) {
int isNew;
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
oPtr->selfCls->classChainCache = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
methodNameObj, &isNew);
} else {
if (oPtr->chainCache == NULL) {
oPtr->chainCache = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->chainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
methodNameObj, &isNew);
}
}
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 |
TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
}
oPtr->selfCls->destructorChainPtr = callPtr;
callPtr->refCount++;
}
returnContext:
| > | | 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 |
TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
}
oPtr->selfCls->destructorChainPtr = callPtr;
callPtr->refCount++;
}
returnContext:
contextPtr = (CallContext *)
TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
contextPtr->oPtr = oPtr;
/*
* Corresponding TclOODecrRefCount() in TclOODeleteContext
*/
AddRef(oPtr);
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
* destructor chain. */
int flags) /* What sort of context are we looking for.
* Only the bits PUBLIC_METHOD, CONSTRUCTOR,
* PRIVATE_METHOD, DESTRUCTOR and
* FILTER_HANDLING are useful. */
{
CallChain *callPtr;
| | > > > > > > > > > > > | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 |
* destructor chain. */
int flags) /* What sort of context are we looking for.
* Only the bits PUBLIC_METHOD, CONSTRUCTOR,
* PRIVATE_METHOD, DESTRUCTOR and
* FILTER_HANDLING are useful. */
{
CallChain *callPtr;
ChainBuilder cb;
Tcl_Size count;
Foundation *fPtr = clsPtr->thisPtr->fPtr;
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
Object obj;
/*
* Note that it's possible to end up with a NULL clsPtr here if there is
* a call into stereotypical object after it has finished running its
* destructor phase. It's quite a tangle, but at that point, we simply
* can't get stereotypes. [Bug 7842f33a5c]
*/
if (clsPtr == NULL) {
return NULL;
}
/*
* Synthesize a temporary stereotypical object so that we can use existing
* machinery to produce the stereotypical call chain.
*/
memset(&obj, 0, sizeof(Object));
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 |
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
| | | | 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 |
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
callPtr = (CallChain *) Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
callPtr->refCount++;
return callPtr;
}
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
} else {
hPtr = NULL;
}
callPtr = (CallChain *) Tcl_Alloc(sizeof(CallChain));
memset(callPtr, 0, sizeof(CallChain));
callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
callPtr->epoch = fPtr->epoch;
callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount;
callPtr->objectEpoch = clsPtr->thisPtr->epoch;
callPtr->refCount = 1;
callPtr->chain = callPtr->staticChain;
|
| ︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 |
TclOODeleteChain(callPtr);
return NULL;
}
} else {
if (hPtr == NULL) {
int isNew;
if (clsPtr->classChainCache == NULL) {
| | > | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 |
TclOODeleteChain(callPtr);
return NULL;
}
} else {
if (hPtr == NULL) {
int isNew;
if (clsPtr->classChainCache == NULL) {
clsPtr->classChainCache = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
methodNameObj, &isNew);
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
* ----------------------------------------------------------------------
*/
static void
AddClassFiltersToCallContext(
Object *const oPtr, /* Object that the filters operate on. */
Class *clsPtr, /* Class to get the filters from. */
| < | | 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 |
* ----------------------------------------------------------------------
*/
static void
AddClassFiltersToCallContext(
Object *const oPtr, /* Object that the filters operate on. */
Class *clsPtr, /* Class to get the filters from. */
ChainBuilder *const cbPtr, /* Context to fill with call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what filters have been
* processed. Keys are objects, values are
* ignored. */
int flags) /* Whether we've gone along a mixin link
* yet. */
{
|
| ︙ | ︙ | |||
1628 1629 1630 1631 1632 1633 1634 |
AddPrivatesFromClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Class *const contextCls, /* Context class; the currently considered
* class is equal to this, private methods may
* also be added. */
Tcl_Obj *const methodName, /* Name of method to add the call chain
* entries for. */
| < | > > > > > > > | | 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 |
AddPrivatesFromClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Class *const contextCls, /* Context class; the currently considered
* class is equal to this, private methods may
* also be added. */
Tcl_Obj *const methodName, /* Name of method to add the call chain
* entries for. */
ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
Tcl_Size i;
Class *superPtr;
/*
* We hard-code the tail-recursive form. It's by far the most common case
* *and* it is much more gentle on the stack.
*
* Note that mixins must be processed before the main class hierarchy.
* [Bug 1998221]
*
* Note also that it's possible to end up with a null classPtr here if
* there is a call into stereotypical object after it has finished running
* its destructor phase. [Bug 7842f33a5c]
*/
tailRecurse:
if (classPtr == NULL) {
return 0;
}
FOREACH(superPtr, classPtr->mixins) {
if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
filterDecl)) {
return 1;
}
}
if (classPtr == contextCls) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
methodName);
if (hPtr != NULL) {
Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
return 1;
}
}
|
| ︙ | ︙ | |||
1706 1707 1708 1709 1710 1711 1712 |
static int
AddSimpleClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Tcl_Obj *const methodNameObj,
/* Name of method to add the call chain
* entries for. */
| < | | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
static int
AddSimpleClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Tcl_Obj *const methodNameObj,
/* Name of method to add the call chain
* entries for. */
ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
|
| ︙ | ︙ | |||
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 |
* *and* it is much more gentle on the stack.
*
* Note that mixins must be processed before the main class hierarchy.
* [Bug 1998221]
*/
tailRecurse:
FOREACH(superPtr, classPtr->mixins) {
privateDanger |= AddSimpleClassChainToCallContext(superPtr,
methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
filterDecl);
}
if (flags & CONSTRUCTOR) {
AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else if (flags & DESTRUCTOR) {
AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
methodNameObj);
if (classPtr->flags & HAS_PRIVATE_METHODS) {
privateDanger |= 1;
}
if (hPtr != NULL) {
| > > > | | 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 |
* *and* it is much more gentle on the stack.
*
* Note that mixins must be processed before the main class hierarchy.
* [Bug 1998221]
*/
tailRecurse:
if (classPtr == NULL) {
return privateDanger;
}
FOREACH(superPtr, classPtr->mixins) {
privateDanger |= AddSimpleClassChainToCallContext(superPtr,
methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
filterDecl);
}
if (flags & CONSTRUCTOR) {
AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else if (flags & DESTRUCTOR) {
AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
methodNameObj);
if (classPtr->flags & HAS_PRIVATE_METHODS) {
privateDanger |= 1;
}
if (hPtr != NULL) {
Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
if (!(flags & KNOWN_STATE)) {
if (flags & PUBLIC_METHOD) {
if (!IS_PUBLIC(mPtr)) {
return privateDanger;
}
|
| ︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 |
Tcl_Size i;
/*
* Allocate the literals (potentially) used in our description.
*/
TclNewLiteralStringObj(filterLiteral, "filter");
| < < < < > | | | > | | | | | 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 |
Tcl_Size i;
/*
* Allocate the literals (potentially) used in our description.
*/
TclNewLiteralStringObj(filterLiteral, "filter");
TclNewLiteralStringObj(methodLiteral, "method");
TclNewLiteralStringObj(objectLiteral, "object");
TclNewLiteralStringObj(privateLiteral, "private");
/*
* Do the actual construction of the descriptions. They consist of a list
* of triples that describe the details of how a method is understood. For
* each triple, the first word is the type of invocation ("method" is
* normal, "unknown" is special because it adds the method name as an
* extra argument when handled by some method types, and "filter" is
* special because it's a filter method). The second word is the name of
* the method in question (which differs for "unknown" and "filter" types)
* and the third word is the full name of the class that declares the
* method (or "object" if it is declared on the instance).
*/
objv = (Tcl_Obj **)
TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
for (i = 0 ; i < callPtr->numChain ; i++) {
MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
miPtr->isFilter ? filterLiteral :
callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
methodLiteral;
descObjs[1] =
callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
callPtr->flags & DESTRUCTOR ? fPtr->destructorName :
miPtr->mPtr->namePtr;
descObjs[2] = miPtr->mPtr->declaringClassPtr
? Tcl_GetObjectName(interp,
(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
: objectLiteral;
descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name,
TCL_AUTO_LENGTH);
objv[i] = Tcl_NewListObj(4, descObjs);
}
/*
* Drop the local references to the literals; if they're actually used,
* they'll live on the description itself.
*/
Tcl_BounceRefCount(filterLiteral);
Tcl_BounceRefCount(methodLiteral);
Tcl_BounceRefCount(objectLiteral);
Tcl_BounceRefCount(privateLiteral);
/*
* Finish building the description and return it.
*/
resultObj = Tcl_NewListObj(callPtr->numChain, objv);
TclStackFree(interp, objv);
|
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 | * reallocating the space for the chain if necessary. * * ---------------------------------------------------------------------- */ static inline void AddDefinitionNamespaceToChain( | | | > | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 |
* reallocating the space for the chain if necessary.
*
* ----------------------------------------------------------------------
*/
static inline void
AddDefinitionNamespaceToChain(
Class *const definerCls, /* What class defines this entry. */
Tcl_Obj *const namespaceName,
/* The name for this entry (or NULL, a
* no-op). */
DefineChain *const definePtr,
/* The define chain to add the method
* implementation to. */
int flags) /* Used to check if we're mixin-consistent
* only. Mixin-consistent means that either
* we're looking to add things from a mixin
|
| ︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 |
*/
if (definePtr->num == definePtr->size) {
definePtr->size *= 2;
if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
DefineEntry *staticList = definePtr->list;
| | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
*/
if (definePtr->num == definePtr->size) {
definePtr->size *= 2;
if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
DefineEntry *staticList = definePtr->list;
definePtr->list = (DefineEntry *)
Tcl_Alloc(sizeof(DefineEntry) * definePtr->size);
memcpy(definePtr->list, staticList,
sizeof(DefineEntry) * definePtr->num);
} else {
definePtr->list = (DefineEntry *) Tcl_Realloc(definePtr->list,
sizeof(DefineEntry) * definePtr->size);
}
}
definePtr->list[i].definerCls = definerCls;
definePtr->list[i].namespaceName = namespaceName;
definePtr->num++;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | */ #define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30 /* * Some things that make it easier to declare a slot. */ | < | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
*/
#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30
/*
* Some things that make it easier to declare a slot.
*/
typedef struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
const Tcl_MethodType resolverType;
} DeclaredSlot;
#define SLOT(name,getter,setter,resolver) \
{"::oo::" name, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
setter, NULL, NULL}, \
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | static inline int InitDefineContext(Tcl_Interp *interp, Tcl_Namespace *namespacePtr, Object *oPtr, int objc, Tcl_Obj *const objv[]); static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); | | | | | | | | > > > > > > > > > > > > | | | > | > > > | | | | | | > > | > > | | | | | | | | > | > | > | > | | 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 |
static inline int InitDefineContext(Tcl_Interp *interp,
Tcl_Namespace *namespacePtr, Object *oPtr,
int objc, Tcl_Obj *const objv[]);
static inline void RecomputeClassCacheFlag(Object *oPtr);
static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
int useClass, Tcl_Obj *const fromPtr,
Tcl_Obj *const toPtr);
static int ClassFilter_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ClassFilter_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ClassMixin_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ClassMixin_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ClassSuper_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ClassSuper_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ClassVars_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ClassVars_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ObjFilter_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ObjFilter_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ObjMixin_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ObjMixin_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ObjVars_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ObjVars_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ClassReadableProps_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ClassReadableProps_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ClassWritableProps_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ClassWritableProps_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ObjectReadableProps_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ObjectReadableProps_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ObjectWritableProps_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_ObjectWritableProps_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int ResolveClass(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
/*
* Now define the slots used in declarations.
*/
static const DeclaredSlot slots[] = {
SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL),
SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass),
SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass),
SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL),
SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL),
SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass),
SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL),
SLOT("configuresupport::readableproperties",
Configurable_ClassReadableProps_Get,
Configurable_ClassReadableProps_Set, NULL),
SLOT("configuresupport::writableproperties",
Configurable_ClassWritableProps_Get,
Configurable_ClassWritableProps_Set, NULL),
SLOT("configuresupport::objreadableproperties",
Configurable_ObjectReadableProps_Get,
Configurable_ObjectReadableProps_Set, NULL),
SLOT("configuresupport::objwritableproperties",
Configurable_ObjectWritableProps_Get,
Configurable_ObjectWritableProps_Set, NULL),
{NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
/*
* How to build the in-namespace name of a private variable. This is a pattern
* used with Tcl_ObjPrintf().
*/
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
RecomputeClassCacheFlag(oPtr);
} else {
/*
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
| | | | | | 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 |
RecomputeClassCacheFlag(oPtr);
} else {
/*
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
size_t size = sizeof(Tcl_Obj *) * numFilters;
if (oPtr->filters.num == 0) {
filtersList = (Tcl_Obj **) Tcl_Alloc(size);
} else {
filtersList = (Tcl_Obj **) Tcl_Realloc(oPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
oPtr->filters.list = filtersList;
oPtr->filters.num = numFilters;
oPtr->flags &= ~USE_CLASS_CACHE;
}
BumpInstanceEpoch(oPtr); // Only this object can be affected.
}
/*
* ----------------------------------------------------------------------
*
* TclOOClassSetFilters --
*
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
classPtr->filters.num = 0;
} else {
/*
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
| | | | > | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
classPtr->filters.num = 0;
} else {
/*
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
size_t size = sizeof(Tcl_Obj *) * numFilters;
if (classPtr->filters.num == 0) {
filtersList = (Tcl_Obj **) Tcl_Alloc(size);
} else {
filtersList = (Tcl_Obj **)
Tcl_Realloc(classPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
classPtr->filters.list = filtersList;
classPtr->filters.num = numFilters;
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 |
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | > | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
oPtr->mixins.list = (Class **) Tcl_Realloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
oPtr->mixins.list = (Class **)
Tcl_Alloc(sizeof(Class *) * numMixins);
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->mixins.num = numMixins;
memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
|
| ︙ | ︙ | |||
502 503 504 505 506 507 508 |
}
} else {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | > | | > | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
}
} else {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
classPtr->mixins.list = (Class **)
Tcl_Realloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
classPtr->mixins.list = (Class **)
Tcl_Alloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
/*
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 |
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
}
if (i != varc) {
if (varc == 0) {
Tcl_Free(vnlPtr->list);
} else if (i) {
| > | | > | | 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 |
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
}
if (i != varc) {
if (varc == 0) {
Tcl_Free(vnlPtr->list);
} else if (i) {
vnlPtr->list = (Tcl_Obj **)
Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
} else {
vnlPtr->list = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * varc);
}
}
vnlPtr->num = 0;
if (varc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<varc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
if (created) {
vnlPtr->list[n++] = varv[i];
} else {
Tcl_DecrRefCount(varv[i]);
}
}
vnlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
vnlPtr->list = (Tcl_Obj **)
Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
static inline void
InstallPrivateVariableMapping(
|
| ︙ | ︙ | |||
605 606 607 608 609 610 611 |
Tcl_DecrRefCount(privatePtr->variableObj);
Tcl_DecrRefCount(privatePtr->fullNameObj);
}
if (i != varc) {
if (varc == 0) {
Tcl_Free(pvlPtr->list);
} else if (i) {
| | > | | > | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 |
Tcl_DecrRefCount(privatePtr->variableObj);
Tcl_DecrRefCount(privatePtr->fullNameObj);
}
if (i != varc) {
if (varc == 0) {
Tcl_Free(pvlPtr->list);
} else if (i) {
pvlPtr->list = (PrivateVariableMapping *)
Tcl_Realloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * varc);
} else {
pvlPtr->list = (PrivateVariableMapping *)
Tcl_Alloc(sizeof(PrivateVariableMapping) * varc);
}
}
pvlPtr->num = 0;
if (varc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<varc ; i++) {
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
pvlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
| | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
pvlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
pvlPtr->list = (PrivateVariableMapping *) Tcl_Realloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
/*
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
if (!useClass) {
if (!oPtr->methodsPtr) {
noSuchMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method %s does not exist", TclGetString(fromPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
| | | | | | 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 |
if (!useClass) {
if (!oPtr->methodsPtr) {
noSuchMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method %s does not exist", TclGetString(fromPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(fromPtr), (char *)NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, fromPtr);
if (hPtr == NULL) {
goto noSuchMethod;
}
if (toPtr) {
newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr,
&isNew);
if (hPtr == newHPtr) {
renameToSelf:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot rename method to itself", TCL_AUTO_LENGTH));
OO_ERROR(interp, RENAME_TO_SELF);
return TCL_ERROR;
} else if (!isNew) {
renameToExisting:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method called %s already exists",
TclGetString(toPtr)));
OO_ERROR(interp, RENAME_OVER);
return TCL_ERROR;
}
}
} else {
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, fromPtr);
if (hPtr == NULL) {
goto noSuchMethod;
|
| ︙ | ︙ | |||
715 716 717 718 719 720 721 |
}
}
/*
* Complete the splicing by changing the method's name.
*/
| | | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
}
}
/*
* Complete the splicing by changing the method's name.
*/
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (toPtr) {
Tcl_IncrRefCount(toPtr);
Tcl_DecrRefCount(mPtr->namePtr);
mPtr->namePtr = toPtr;
Tcl_SetHashValue(newHPtr, mPtr);
} else {
if (!useClass) {
|
| ︙ | ︙ | |||
752 753 754 755 756 757 758 |
TclOOUnknownDefinition(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
| | < | | | | | < < < < | | | 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 |
TclOOUnknownDefinition(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
FOREACH_HASH_DECLS;
Tcl_Size soughtLen;
const char *soughtStr, *nameStr, *matchedStr = NULL;
if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad call of unknown handler", TCL_AUTO_LENGTH));
OO_ERROR(interp, BAD_UNKNOWN);
return TCL_ERROR;
}
if (TclOOGetDefineCmdContext(interp) == NULL) {
return TCL_ERROR;
}
soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
FOREACH_HASH_KEY(nameStr, &nsPtr->cmdTable) {
if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
if (matchedStr != NULL) {
goto noMatch;
}
matchedStr = nameStr;
}
}
if (matchedStr != NULL) {
/*
* Got one match, and only one match!
*/
Tcl_Obj **newObjv = (Tcl_Obj **)
TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
int result;
newObjv[0] = Tcl_NewStringObj(matchedStr, TCL_AUTO_LENGTH);
Tcl_IncrRefCount(newObjv[0]);
if (objc > 2) {
memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
}
result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
Tcl_DecrRefCount(newObjv[0]);
TclStackFree(interp, newObjv);
return result;
}
noMatch:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", soughtStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, (char *)NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* FindCommand --
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
Tcl_Size length;
| | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
Tcl_Size length;
const char *nameStr, *string = TclGetStringFromObj(stringObj, &length);
Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
/*
* If someone is playing games, we stop playing right now.
*/
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
int objc,
Tcl_Obj *const objv[])
{
CallFrame *framePtr, **framePtrPtr = &framePtr;
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | | > | | | | > > > > > > > > > > > > > > > > > | 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 |
int objc,
Tcl_Obj *const objv[])
{
CallFrame *framePtr, **framePtrPtr = &framePtr;
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no definition namespace available", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
/*
* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
*/
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, FRAME_IS_OO_DEFINE);
framePtr->clientData = oPtr;
framePtr->objc = objc;
framePtr->objv = objv; /* Reference counts do not need to be
* incremented here. */
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetDefineCmdContext, TclOOGetClassDefineCmdContext --
*
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
*
* ----------------------------------------------------------------------
*/
Tcl_Object
TclOOGetDefineCmdContext(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
|| (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
&& iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command may only be called from within the context of"
" an ::oo::define or ::oo::objdefine command",
TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return NULL;
}
object = (Tcl_Object) iPtr->varFramePtr->clientData;
if (Tcl_ObjectDeleted(object)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command cannot be called when the object has been"
" deleted", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return NULL;
}
return object;
}
Class *
TclOOGetClassDefineCmdContext(
Tcl_Interp *interp)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return NULL;
}
if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return NULL;
}
return oPtr->classPtr;
}
/*
* ----------------------------------------------------------------------
*
* GetClassInOuterContext, GetNamespaceInOuterContext --
*
* Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to
|
| ︙ | ︙ | |||
988 989 990 991 992 993 994 |
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
iPtr->varFramePtr = savedFramePtr;
if (oPtr == NULL) {
return NULL;
}
if (oPtr->classPtr == NULL) {
| | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
iPtr->varFramePtr = savedFramePtr;
if (oPtr == NULL) {
return NULL;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(className), (char *)NULL);
return NULL;
}
return oPtr->classPtr;
}
static inline Tcl_Namespace *
GetNamespaceInOuterContext(
|
| ︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 |
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
Tcl_Size length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
| | | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 |
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
Tcl_Size length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
const char *objName = TclGetStringFromObj(realNameObj, &length);
int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in definition script for %s \"%.*s%s\" line %d)",
typeOfSubject, (overflow ? limit : (int) length), objName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
/*
* ----------------------------------------------------------------------
*
* MagicDefinitionInvoke --
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
*/
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
} else {
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
| | | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 |
*/
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
} else {
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
// TODO: overflow?
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
TclListObjGetElements(NULL, objPtr, &dummy, &objs);
result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
if (isRoot) {
TclResetRewriteEnsemble(interp, 1);
}
Tcl_DecrRefCount(objPtr);
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s does not refer to a class", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
| | | | 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 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s does not refer to a class", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[1]), (char *)NULL);
return TCL_ERROR;
}
/*
* Make the oo::define namespace the current namespace and evaluate the
* command(s).
*/
nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1);
if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
AddRef(oPtr);
if (objc == 3) {
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
((Interp *) interp)->cmdFramePtr, 2);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "class");
}
TclDecrRefCount(objNameObj);
} else {
result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
AddRef(oPtr);
if (objc == 3) {
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
| | | 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 |
AddRef(oPtr);
if (objc == 3) {
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
((Interp *) interp)->cmdFramePtr, 2);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "object");
}
TclDecrRefCount(objNameObj);
} else {
result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
|
| ︙ | ︙ | |||
1329 1330 1331 1332 1333 1334 1335 |
AddRef(oPtr);
if (objc == 2) {
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
| | | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 |
AddRef(oPtr);
if (objc == 2) {
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
((Interp *) interp)->cmdFramePtr, 1);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
}
TclDecrRefCount(objNameObj);
} else {
result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv);
}
|
| ︙ | ︙ | |||
1487 1488 1489 1490 1491 1492 1493 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->flags & ROOT_OBJECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | > | | > | | > | | 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 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->flags & ROOT_OBJECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the class of the root object class",
TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
if (oPtr->flags & ROOT_CLASS) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the class of the class of classes",
TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
/*
* Parse the argument to get the class to set the object's class to.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = GetClassInOuterContext(interp, objv[1],
"the class of an object must be a class");
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (oPtr == clsPtr->thisPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not change classes into an instance of themselves",
TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
/*
* Set the object's class.
*/
|
| ︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 |
int
TclOODefineConstructorObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| < | > > | < < < < < < < < < < < | | 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 |
int
TclOODefineConstructorObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Method method;
Tcl_Size bodyLength;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
return TCL_ERROR;
}
(void) TclGetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
*/
method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
PUBLIC_METHOD, NULL, objv[1], objv[2], NULL);
|
| ︙ | ︙ | |||
1656 1657 1658 1659 1660 1661 1662 |
{
static const char *kindList[] = {
"-class",
"-instance",
NULL
};
int kind = 0;
| | < | < < < < < < < | | | | 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 |
{
static const char *kindList[] = {
"-class",
"-instance",
NULL
};
int kind = 0;
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Namespace *nsPtr;
Tcl_Obj *nsNamePtr, **storagePtr;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (clsPtr->thisPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the definition namespace of the root classes",
TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
/*
* Parse the arguments and work out what the user wants to do.
*/
|
| ︙ | ︙ | |||
1697 1698 1699 1700 1701 1702 1703 |
if (!TclGetString(objv[objc - 1])[0]) {
nsNamePtr = NULL;
} else {
nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
if (nsPtr == NULL) {
return TCL_ERROR;
}
| | | | | 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 |
if (!TclGetString(objv[objc - 1])[0]) {
nsNamePtr = NULL;
} else {
nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
if (nsPtr == NULL) {
return TCL_ERROR;
}
nsNamePtr = TclNewNamespaceObj(nsPtr);
Tcl_IncrRefCount(nsNamePtr);
}
/*
* Update the correct field of the class definition.
*/
if (kind) {
storagePtr = &clsPtr->objDefinitionNs;
} else {
storagePtr = &clsPtr->clsDefinitionNs;
}
if (*storagePtr != NULL) {
Tcl_DecrRefCount(*storagePtr);
}
*storagePtr = nsNamePtr;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1750 1751 1752 1753 1754 1755 1756 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
/*
* Delete the method structure from the appropriate hash table.
*/
|
| ︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 |
int
TclOODefineDestructorObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| < < > > > | < < < | < < | | 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 |
int
TclOODefineDestructorObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Method method;
Tcl_Size bodyLength;
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
(void) TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
*/
method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
PUBLIC_METHOD, NULL, NULL, objv[1], NULL);
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | > | | | 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 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
/*
* Exporting is done by adding the PUBLIC_METHOD flag to the method
* record. If there is no such method in this object or class (i.e.
* the method comes from something inherited from or that we're an
* instance of) then we put in a blank record with that flag; such
* records are skipped over by the call chain engine *except* for
* their flags member.
*/
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *) Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *) Tcl_GetHashValue(hPtr);
}
if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
mPtr->flags |= PUBLIC_METHOD;
mPtr->flags &= ~TRUE_PRIVATE_METHOD;
changed = 1;
}
}
|
| ︙ | ︙ | |||
1970 1971 1972 1973 1974 1975 1976 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceForward && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceForward && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
}
|
| ︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
if (objc == 5) {
if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
0, &exportMode) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2127 2128 2129 2130 2131 2132 2133 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceRenameMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceRenameMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
/*
* Delete the method entry from the appropriate hash table, and transfer
* the thing it points to to its new entry. To do this, we first need to
* get the entries from the appropriate hash tables (this can generate a
|
| ︙ | ︙ | |||
2189 2190 2191 2192 2193 2194 2195 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceUnexport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | > | | | 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 2265 2266 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceUnexport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
/*
* Unexporting is done by removing the PUBLIC_METHOD flag from the
* method record. If there is no such method in this object or class
* (i.e. the method comes from something inherited from or that we're
* an instance of) then we put in a blank record without that flag;
* such records are skipped over by the call chain engine *except* for
* their flags member.
*/
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)
Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *) Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *) Tcl_GetHashValue(hPtr);
}
if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
changed = 1;
}
}
|
| ︙ | ︙ | |||
2317 2318 2319 2320 2321 2322 2323 |
* ----------------------------------------------------------------------
*/
int
TclOODefineSlots(
Foundation *fPtr)
{
| | > | | < > > > > | < | > | | | | > | | | | | | | | | > > | < < < < < < < | < | | | > > | < < < < < < < | | | | | > > | < < < < < < < | < | | | > > | < < < < < < < < | | | > | | | | | | | | > > | < < < < < < < | < | | | > > | | < < < < < < | | > | | | | | | | | | | > | | 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 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 |
* ----------------------------------------------------------------------
*/
int
TclOODefineSlots(
Foundation *fPtr)
{
const DeclaredSlot *slotInfoPtr;
Tcl_Interp *interp = fPtr->interp;
Tcl_Obj *getName, *setName, *resolveName;
Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
Class *slotCls;
if (object == NULL) {
return TCL_ERROR;
}
slotCls = ((Object *) object)->classPtr;
if (slotCls == NULL) {
return TCL_ERROR;
}
TclNewLiteralStringObj(getName, "Get");
TclNewLiteralStringObj(setName, "Set");
TclNewLiteralStringObj(resolveName, "Resolve");
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
(Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE,
NULL, 0);
if (slotObject == NULL) {
continue;
}
TclNewInstanceMethod(interp, slotObject, getName, 0,
&slotInfoPtr->getterType, NULL);
TclNewInstanceMethod(interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
if (slotInfoPtr->resolverType.callProc) {
TclNewInstanceMethod(interp, slotObject, resolveName, 0,
&slotInfoPtr->resolverType, NULL);
}
}
Tcl_BounceRefCount(getName);
Tcl_BounceRefCount(setName);
Tcl_BounceRefCount(resolveName);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ClassFilter_Get, ClassFilter_Set --
*
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassFilter_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
Tcl_Size i;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(filterObj, clsPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassFilter_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size filterc;
Tcl_Obj **filterv;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
TclOOClassSetFilters(interp, clsPtr, filterc, filterv);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ClassMixin_Get, ClassMixin_Set --
*
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassMixin_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *mixinPtr;
Tcl_Size i;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(mixinPtr, clsPtr->mixins) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassMixin_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(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 (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(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",
TCL_AUTO_LENGTH));
OO_ERROR(interp, REPETITIOUS);
goto freeAndError;
}
if (TclOOIsReachable(clsPtr, mixins[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not mix a class into itself", TCL_AUTO_LENGTH));
OO_ERROR(interp, SELF_MIXIN);
goto freeAndError;
}
}
TclOOClassSetMixins(interp, clsPtr, mixinc, mixins);
Tcl_DeleteHashTable(&uniqueCheck);
TclStackFree(interp, mixins);
return TCL_OK;
freeAndError:
Tcl_DeleteHashTable(&uniqueCheck);
TclStackFree(interp, mixins);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* ClassSuper_Get, ClassSuper_Set --
*
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassSuper_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *superPtr;
Tcl_Size i;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(superPtr, clsPtr->superclasses) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, superPtr->thisPtr));
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassSuper_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size superc, j;
Tcl_Size i;
Tcl_Obj **superv;
Class **superclasses, *superPtr;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"superclassList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
Foundation *fPtr = clsPtr->thisPtr->fPtr;
if (clsPtr == fPtr->objectCls) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the superclass of the root object",
TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
} else if (TclListObjGetElements(interp, objv[0], &superc,
&superv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Allocate some working space.
*/
superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc);
/*
* Parse the arguments to get the class to use as superclasses.
*
* Note that zero classes is special, as it is equivalent to just the
* class of objects. [Bug 9d61624b3d]
*/
if (superc == 0) {
superclasses = (Class **) Tcl_Realloc(superclasses, sizeof(Class *));
if (TclOOIsReachable(fPtr->classCls, clsPtr)) {
superclasses[0] = fPtr->classCls;
} else {
superclasses[0] = fPtr->objectCls;
}
superc = 1;
AddRef(superclasses[0]->thisPtr);
} else {
for (i = 0; i < superc; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
for (j = 0; j < i; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once",
TCL_AUTO_LENGTH));
OO_ERROR(interp, REPETITIOUS);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(clsPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph",
TCL_AUTO_LENGTH));
OO_ERROR(interp, CIRCULARITY);
failedAfterAlloc:
for (; i-- > 0 ;) {
TclOODecrRefCount(superclasses[i]->thisPtr);
}
Tcl_Free(superclasses);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2705 2706 2707 2708 2709 2710 2711 |
/*
* Install the list of superclasses into the class. Note that this also
* involves splicing the class out of the superclasses' subclass list that
* it used to be a member of and splicing it into the new superclasses'
* subclass list.
*/
| | | | | | | | | | | | | > > | < < < < < < < < | | | | > > | < < < < < < < < | | | | | | | | | 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 |
/*
* Install the list of superclasses into the class. Note that this also
* involves splicing the class out of the superclasses' subclass list that
* it used to be a member of and splicing it into the new superclasses'
* subclass list.
*/
if (clsPtr->superclasses.num != 0) {
FOREACH(superPtr, clsPtr->superclasses) {
TclOORemoveFromSubclasses(clsPtr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
Tcl_Free(clsPtr->superclasses.list);
}
clsPtr->superclasses.list = superclasses;
clsPtr->superclasses.num = superc;
FOREACH(superPtr, clsPtr->superclasses) {
TclOOAddToSubclasses(clsPtr, superPtr);
}
BumpGlobalEpoch(interp, clsPtr);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ClassVars_Get, ClassVars_Set --
*
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassVars_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj;
Tcl_Size i;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
if (IsPrivateDefine(interp)) {
PrivateVariableMapping *privatePtr;
FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
Tcl_Obj *variableObj;
FOREACH(variableObj, clsPtr->variables) {
Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassVars_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size i;
Tcl_Size varc;
Tcl_Obj **varv;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
OO_ERROR(interp, BAD_DECLVAR);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "refer to an array element"));
OO_ERROR(interp, BAD_DECLVAR);
return TCL_ERROR;
}
}
if (IsPrivateDefine(interp)) {
InstallPrivateVariableMapping(&clsPtr->privateVariables,
varc, varv, clsPtr->thisPtr->creationEpoch);
} else {
InstallStandardVariableMapping(&clsPtr->variables, varc, varv);
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ObjFilter_Get, ObjFilter_Set --
*
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjFilter_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
|
| ︙ | ︙ | |||
2877 2878 2879 2880 2881 2882 2883 |
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
| | < | | | | 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 |
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjFilter_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size filterc;
Tcl_Obj **filterv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) {
return TCL_ERROR;
}
TclOOObjectSetFilters(oPtr, filterc, filterv);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ObjMixin_Get, ObjMixin_Set --
*
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjMixin_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
|
| ︙ | ︙ | |||
2949 2950 2951 2952 2953 2954 2955 |
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
| | | 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 |
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjMixin_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
|
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
| < | | | > | | | | 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 3020 3021 3022 3023 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(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",
TCL_AUTO_LENGTH));
OO_ERROR(interp, REPETITIOUS);
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;
}
/*
* ----------------------------------------------------------------------
*
* ObjVars_Get, ObjVars_Set --
*
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjVars_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
|
| ︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 |
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
| | < | | | | 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 |
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjVars_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size varc, i;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"variableList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
OO_ERROR(interp, BAD_DECLVAR);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "refer to an array element"));
OO_ERROR(interp, BAD_DECLVAR);
return TCL_ERROR;
}
}
if (IsPrivateDefine(interp)) {
InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
oPtr->creationEpoch);
|
| ︙ | ︙ | |||
3166 3167 3168 3169 3170 3171 3172 |
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
| | > | | | > > | | < < | < | > | > | > < < > > | < < | < | | > | | > | > > | | | < < | < < < | < | < > > > | > | < | < < < | < < < | < | > > > | < < > > | < < < < < < < | < < < < < | | > > > > | > > > | > > > > > > > > > > > | > > > > > > > > > | > | < > > | < | | > | < > > | < > > | > < | < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < | < < < < < | | < < < < < | | < > > > > > > > > > > > > > > > > > > > > > > > | < < < < < | | | < > | > | > > > | < < > | < | > > > | | > > > > > > > > > > > > > | > > > | | | > > | < > > > > | > | < < < < < < < | < > | > | > > > > > > > > | > | > > | | < > > > > < > | < | > | < > > > | < < | 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 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 |
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* Configurable_ClassReadableProps_Get, Configurable_ClassReadableProps_Set,
* Configurable_ObjectReadableProps_Get, Configurable_ObjectReadableProps_Set --
*
* Implementations of the "readableproperties" slot accessors for classes
* and instances.
*
* ----------------------------------------------------------------------
*/
static int
Configurable_ClassReadableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOGetPropertyList(&clsPtr->properties.readable));
return TCL_OK;
}
static int
Configurable_ClassReadableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
TclOOInstallReadableProperties(&clsPtr->properties, varc, varv);
BumpGlobalEpoch(interp, clsPtr);
return TCL_OK;
}
static int
Configurable_ObjectReadableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOGetPropertyList(&oPtr->properties.readable));
return TCL_OK;
}
static int
Configurable_ObjectReadableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (TclListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
TclOOInstallReadableProperties(&oPtr->properties, varc, varv);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* Configurable_ClassWritableProps_Get, Configurable_ClassWritableProps_Set,
* Configurable_ObjectWritableProps_Get, Configurable_ObjectWritableProps_Set --
*
* Implementations of the "writableproperties" slot accessors for classes
* and instances.
*
* ----------------------------------------------------------------------
*/
static int
Configurable_ClassWritableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOGetPropertyList(&clsPtr->properties.writable));
return TCL_OK;
}
static int
Configurable_ClassWritableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"propertyList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
TclOOInstallWritableProperties(&clsPtr->properties, varc, varv);
BumpGlobalEpoch(interp, clsPtr);
return TCL_OK;
}
static int
Configurable_ObjectWritableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOGetPropertyList(&oPtr->properties.writable));
return TCL_OK;
}
static int
Configurable_ObjectWritableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"propertyList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (TclListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
TclOOInstallWritableProperties(&oPtr->properties, varc, varv);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOORegisterProperty, TclOORegisterInstanceProperty --
*
* Helpers to add or remove a name from the property slots of a class or
* instance.
*
* BuildPropertyList --
*
* Helper for the helpers. Scans a property list and does the filtering
* or adding of the property to add or remove
*
* ----------------------------------------------------------------------
*/
static int
BuildPropertyList(
PropertyList *propsList, /* Property list to scan. */
Tcl_Obj *propName, /* Property to add/remove. */
int addingProp, /* True if we're adding, false if removing. */
Tcl_Obj *listObj) /* The list of property names we're building */
{
int present = 0, changed = 0, i;
Tcl_Obj *other;
Tcl_SetListObj(listObj, 0, NULL);
FOREACH(other, *propsList) {
if (!TclStringCmp(propName, other, 1, 0, TCL_INDEX_NONE)) {
present = 1;
if (!addingProp) {
changed = 1;
continue;
}
}
Tcl_ListObjAppendElement(NULL, listObj, other);
}
if (!present && addingProp) {
Tcl_ListObjAppendElement(NULL, listObj, propName);
changed = 1;
}
return changed;
}
void
TclOORegisterInstanceProperty(
Object *oPtr, /* Object that owns the property slots. */
Tcl_Obj *propName, /* Property to add/remove. Must include the
* hyphen if one is desired; this is the value
* that is actually placed in the slot. */
int registerReader, /* True if we're adding the property name to
* the readable property slot. False if we're
* removing the property name from the slot. */
int registerWriter) /* True if we're adding the property name to
* the writable property slot. False if we're
* removing the property name from the slot. */
{
Tcl_Obj *listObj = Tcl_NewObj(); /* Working buffer. */
Tcl_Obj **objv;
Tcl_Size count;
if (BuildPropertyList(&oPtr->properties.readable, propName, registerReader,
listObj)) {
TclListObjGetElements(NULL, listObj, &count, &objv);
TclOOInstallReadableProperties(&oPtr->properties, count, objv);
}
if (BuildPropertyList(&oPtr->properties.writable, propName, registerWriter,
listObj)) {
TclListObjGetElements(NULL, listObj, &count, &objv);
TclOOInstallWritableProperties(&oPtr->properties, count, objv);
}
Tcl_BounceRefCount(listObj);
}
void
TclOORegisterProperty(
Class *clsPtr, /* Class that owns the property slots. */
Tcl_Obj *propName, /* Property to add/remove. Must include the
* hyphen if one is desired; this is the value
* that is actually placed in the slot. */
int registerReader, /* True if we're adding the property name to
* the readable property slot. False if we're
* removing the property name from the slot. */
int registerWriter) /* True if we're adding the property name to
* the writable property slot. False if we're
* removing the property name from the slot. */
{
Tcl_Obj *listObj = Tcl_NewObj(); /* Working buffer. */
Tcl_Obj **objv;
Tcl_Size count;
int changed = 0;
if (BuildPropertyList(&clsPtr->properties.readable, propName,
registerReader, listObj)) {
TclListObjGetElements(NULL, listObj, &count, &objv);
TclOOInstallReadableProperties(&clsPtr->properties, count, objv);
changed = 1;
}
if (BuildPropertyList(&clsPtr->properties.writable, propName,
registerWriter, listObj)) {
TclListObjGetElements(NULL, listObj, &count, &objv);
TclOOInstallWritableProperties(&clsPtr->properties, count, objv);
changed = 1;
}
Tcl_BounceRefCount(listObj);
if (changed) {
BumpGlobalEpoch(clsPtr->thisPtr->fPtr->interp, clsPtr);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclOOInfo.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" | < < < < | | 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 |
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
static Tcl_ObjCmdProc InfoObjectFiltersCmd;
static Tcl_ObjCmdProc InfoObjectForwardCmd;
static Tcl_ObjCmdProc InfoObjectIdCmd;
static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDefnNsCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
/*
* List of commands that are used to implement the [info object] subcommands.
*/
static const EnsembleImplMap infoObjectCmds[] = {
{"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
{"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0},
{"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
{"properties", TclOOInfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* List of commands that are used to implement the [info class] subcommands.
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
{"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
| | > > > > > > > > > > > > > > > > > | 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 |
{"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"properties", TclOOInfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* ----------------------------------------------------------------------
*
* LocalVarName --
*
* Get the name of a local variable (especially a method argument) as a
* Tcl value.
*
* ----------------------------------------------------------------------
*/
static inline Tcl_Obj *
LocalVarName(
CompiledLocal *localPtr)
{
return Tcl_NewStringObj(localPtr->name, TCL_AUTO_LENGTH);
}
/*
* ----------------------------------------------------------------------
*
* TclOOInitInfo --
*
* Adjusts the Tcl core [info] command to contain subcommands ("object"
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
/*
* Install into the [info] ensemble.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (infoCmd) {
Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
| < | < | | | | | | 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 |
/*
* Install into the [info] ensemble.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (infoCmd) {
Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
TclDictPutString(NULL, mapDict, "object", "::oo::InfoObject");
TclDictPutString(NULL, mapDict, "class", "::oo::InfoClass");
Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
}
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetClassFromObj --
*
* How to correctly get a class from a Tcl_Obj. Just a wrapper round
* Tcl_GetObjectFromObj, but this is an idiom that was used heavily.
*
* ----------------------------------------------------------------------
*/
Class *
TclOOGetClassFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr);
if (oPtr == NULL) {
return NULL;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objPtr), (char *)NULL);
return NULL;
}
return oPtr->classPtr;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
Tcl_SetObjResult(interp,
TclOOObjectName(interp, oPtr->selfCls->thisPtr));
return TCL_OK;
} else {
Class *mixinPtr, *o2clsPtr;
Tcl_Size i;
| | | | | 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 |
Tcl_SetObjResult(interp,
TclOOObjectName(interp, oPtr->selfCls->thisPtr));
return TCL_OK;
} else {
Class *mixinPtr, *o2clsPtr;
Tcl_Size i;
o2clsPtr = TclOOGetClassFromObj(interp, objv[2]);
if (o2clsPtr == NULL) {
return TCL_ERROR;
}
FOREACH(mixinPtr, oPtr->mixins) {
if (!mixinPtr) {
continue;
}
if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
return TCL_OK;
}
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
| | < < < < < | < < < < < > > > > > | < | > > > > > > > > > > > > > > > > > > > | 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 |
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
goto unknownMethod;
}
procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
goto wrongType;
}
/*
* We now have the method to describe the definition of.
*/
TclNewObj(resultObjs[0]);
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
Tcl_Obj *argObj;
TclNewObj(argObj);
Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
/*
* Errors...
*/
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
wrongType:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectFiltersCmd --
*
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
| > > > > > > > > > > > > > > > > > > | | | | | | | < < > | | | | | | < < < < | 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 |
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
goto unknownMethod;
}
prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
goto wrongType;
}
/*
* Describe the valid forward method.
*/
Tcl_SetObjResult(interp, prefixObj);
return TCL_OK;
/*
* Errors...
*/
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
wrongType:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectIsACmd --
*
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 |
static int
InfoObjectMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < < < < < | > > > > > > > > > > | 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 |
static int
InfoObjectMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const options[] = {
"-all", "-localprivate", "-private", "-scope", NULL
};
enum Options {
OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
} idx;
static const char *const scopes[] = {
"private", "public", "unexported"
};
enum Scopes {
SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
SCOPE_LOCALPRIVATE,
SCOPE_DEFAULT = -1
};
Object *oPtr;
int flag = PUBLIC_METHOD, recurse = 0, scope = SCOPE_DEFAULT;
FOREACH_HASH_DECLS;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
/*
* Parse arguments.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?");
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
flag = 0;
break;
case OPT_SCOPE:
if (++i >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing option for -scope"));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
| | | > > > > | > > > > > > | > > > > > > | | > | 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 |
flag = 0;
break;
case OPT_SCOPE:
if (++i >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing option for -scope"));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
(char *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
&scope) != TCL_OK) {
return TCL_ERROR;
}
break;
}
}
}
if (scope != SCOPE_DEFAULT) {
recurse = 0;
switch (scope) {
case SCOPE_PRIVATE:
flag = TRUE_PRIVATE_METHOD;
break;
case SCOPE_PUBLIC:
flag = PUBLIC_METHOD;
break;
case SCOPE_LOCALPRIVATE:
flag = PRIVATE_METHOD;
break;
case SCOPE_UNEXPORTED:
flag = 0;
break;
}
}
/*
* List matching methods.
*/
TclNewObj(resultObj);
if (recurse) {
const char **names;
int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
&names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], TCL_AUTO_LENGTH));
}
if (numNames > 0) {
Tcl_Free((void *)names);
}
} else if (oPtr->methodsPtr) {
if (scope == SCOPE_DEFAULT) {
/*
* Handle legacy-mode matching. [Bug 36e5517a6850]
*/
int scopeFilter = flag | TRUE_PRIVATE_METHOD;
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
if (mPtr->typePtr && (mPtr->flags & scopeFilter) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
} else {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
| | < < < < < | | > > > > > > > > | 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 |
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
goto unknownMethod;
}
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
* exist.
*/
goto unknownMethod;
}
Tcl_SetObjResult(interp,
Tcl_NewStringObj(mPtr->typePtr->name, TCL_AUTO_LENGTH));
return TCL_OK;
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectMixinsCmd --
*
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
| | < | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 |
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclNewNamespaceObj(oPtr->namespacePtr));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectVariablesCmd --
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
return TCL_ERROR;
}
isPrivate = 1;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
| > > > > | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"option \"%s\" is not exactly \"-private\"",
TclGetString(objv[2])));
OO_ERROR(interp, BAD_ARG);
return TCL_ERROR;
}
isPrivate = 1;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
934 935 936 937 938 939 940 |
Tcl_Obj *resultObjs[2];
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
| | | > | | < | 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 |
Tcl_Obj *resultObjs[2];
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (clsPtr->constructorPtr == NULL) {
return TCL_OK;
}
procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method",
TCL_AUTO_LENGTH));
OO_ERROR(interp, METHOD_TYPE);
return TCL_ERROR;
}
TclNewObj(resultObjs[0]);
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
Tcl_Obj *argObj;
TclNewObj(argObj);
Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 |
Tcl_Obj *resultObjs[2];
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
| | | | | > | | < | | 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 |
Tcl_Obj *resultObjs[2];
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
TclNewObj(resultObjs[0]);
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
Tcl_Obj *argObj;
TclNewObj(argObj);
Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 |
Tcl_Obj *nsNamePtr;
Class *clsPtr;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?");
return TCL_ERROR;
}
| | | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 |
Tcl_Obj *nsNamePtr;
Class *clsPtr;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0,
&kind) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 |
Proc *procPtr;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
| | | > | | 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 |
Proc *procPtr;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (clsPtr->destructorPtr == NULL) {
return TCL_OK;
}
procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method",
TCL_AUTO_LENGTH));
OO_ERROR(interp, METHOD_TYPE);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1156 1157 1158 1159 1160 1161 1162 |
Tcl_Obj *filterObj, *resultObj;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
| | | 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 |
Tcl_Obj *filterObj, *resultObj;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(filterObj, clsPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
|
| ︙ | ︙ | |||
1194 1195 1196 1197 1198 1199 1200 |
Tcl_Obj *prefixObj;
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
| | | | | | | 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 |
Tcl_Obj *prefixObj;
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, prefixObj);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 |
const char *pattern = NULL;
Tcl_Obj *resultObj;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
| | | 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 |
const char *pattern = NULL;
Tcl_Obj *resultObj;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
|
| ︙ | ︙ | |||
1285 1286 1287 1288 1289 1290 1291 |
static int
InfoClassMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| < < < < | > > > > > | | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 |
static int
InfoClassMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const options[] = {
"-all", "-localprivate", "-private", "-scope", NULL
};
enum Options {
OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
} idx;
static const char *const scopes[] = {
"private", "public", "unexported"
};
enum Scopes {
SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
SCOPE_DEFAULT = -1
};
int flag = PUBLIC_METHOD, recurse = 0, scope = SCOPE_DEFAULT;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
Class *clsPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc != 2) {
int i;
for (i=2 ; i<objc ; i++) {
|
| ︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 |
flag = 0;
break;
case OPT_SCOPE:
if (++i >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing option for -scope"));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
| | | | 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
flag = 0;
break;
case OPT_SCOPE:
if (++i >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing option for -scope"));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
(char *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
&scope) != TCL_OK) {
return TCL_ERROR;
}
break;
}
}
}
if (scope != SCOPE_DEFAULT) {
recurse = 0;
switch (scope) {
case SCOPE_PRIVATE:
flag = TRUE_PRIVATE_METHOD;
break;
case SCOPE_PUBLIC:
flag = PUBLIC_METHOD;
|
| ︙ | ︙ | |||
1366 1367 1368 1369 1370 1371 1372 |
TclNewObj(resultObj);
if (recurse) {
const char **names;
Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
| | > > > > > > | > > > > > > | | > | 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 |
TclNewObj(resultObj);
if (recurse) {
const char **names;
Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], TCL_AUTO_LENGTH));
}
if (numNames > 0) {
Tcl_Free((void *)names);
}
} else {
FOREACH_HASH_DECLS;
if (scope == SCOPE_DEFAULT) {
/*
* Handle legacy-mode matching. [Bug 36e5517a6850]
*/
int scopeFilter = flag | TRUE_PRIVATE_METHOD;
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
if (mPtr->typePtr && (mPtr->flags & scopeFilter) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
} else {
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1409 1410 1411 1412 1413 1414 1415 |
Method *mPtr;
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
| | | < < < < < | | > > > > > > > > | 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 |
Method *mPtr;
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
if (hPtr == NULL) {
goto unknownMethod;
}
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
* exist.
*/
goto unknownMethod;
}
Tcl_SetObjResult(interp,
Tcl_NewStringObj(mPtr->typePtr->name, TCL_AUTO_LENGTH));
return TCL_OK;
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassMixinsCmd --
*
|
| ︙ | ︙ | |||
1461 1462 1463 1464 1465 1466 1467 |
Tcl_Obj *resultObj;
Tcl_Size i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
| | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 |
Tcl_Obj *resultObj;
Tcl_Size i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(mixinPtr, clsPtr->mixins) {
if (!mixinPtr) {
|
| ︙ | ︙ | |||
1504 1505 1506 1507 1508 1509 1510 |
Tcl_Size i;
const char *pattern = NULL;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
| | | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 |
Tcl_Size i;
const char *pattern = NULL;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
|
| ︙ | ︙ | |||
1558 1559 1560 1561 1562 1563 1564 |
Tcl_Obj *resultObj;
Tcl_Size i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
| | | 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 |
Tcl_Obj *resultObj;
Tcl_Size i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(superPtr, clsPtr->superclasses) {
Tcl_ListObjAppendElement(NULL, resultObj,
|
| ︙ | ︙ | |||
1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 |
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
return TCL_ERROR;
}
isPrivate = 1;
}
| > > > > | | 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 |
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"option \"%s\" is not exactly \"-private\"",
TclGetString(objv[2])));
OO_ERROR(interp, BAD_ARG);
return TCL_ERROR;
}
isPrivate = 1;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
if (isPrivate) {
PrivateVariableMapping *privatePtr;
|
| ︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 |
* Get the call context and render its call chain.
*/
contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | > | 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
* Get the call context and render its call chain.
*/
contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", TCL_AUTO_LENGTH));
OO_ERROR(interp, BAD_CALL_CHAIN);
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
TclOORenderCallChain(interp, contextPtr->callPtr));
TclOODeleteContext(contextPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1697 1698 1699 1700 1701 1702 1703 |
Class *clsPtr;
CallChain *callPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
| | | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
Class *clsPtr;
CallChain *callPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
/*
* Get an render the stereotypical call chain.
*/
callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
if (callPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", TCL_AUTO_LENGTH));
OO_ERROR(interp, BAD_CALL_CHAIN);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
TclOODeleteChain(callPtr);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclOOInt.h.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | #define Object TclOOObject #endif /* __OBJC__ */ /* * Forward declarations. */ | | > | > > | > > | > > > < | > | > | | > > > | < | < | | < | | > > > | > > > > > > > > > > | > > | | > | > | | | < | < < | | | < | | 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 |
#define Object TclOOObject
#endif /* __OBJC__ */
/*
* Forward declarations.
*/
typedef struct CallChain CallChain;
typedef struct CallContext CallContext;
typedef struct Class Class;
typedef struct DeclaredClassMethod DeclaredClassMethod;
typedef struct ForwardMethod ForwardMethod;
typedef struct Foundation Foundation;
typedef struct Method Method;
typedef struct MInvoke MInvoke;
typedef struct Object Object;
typedef struct PrivateVariableMapping PrivateVariableMapping;
typedef struct ProcedureMethod ProcedureMethod;
typedef struct PropertyStorage PropertyStorage;
/*
* The data that needs to be stored per method. This record is used to collect
* information about all sorts of methods, including forwards, constructors
* and destructors.
*/
struct Method {
union {
const Tcl_MethodType *typePtr;
const Tcl_MethodType2 *type2Ptr;
}; /* The type of method. If NULL, this is a
* special flag record which is just used for
* the setting of the flags field. Note that
* this is a union of two pointer types that
* have the same layout at least as far as the
* internal version field. */
Tcl_Size refCount;
void *clientData; /* Type-specific data. */
Tcl_Obj *namePtr; /* Name of the method. */
Object *declaringObjectPtr; /* The object that declares this method, or
* NULL if it was declared by a class. */
Class *declaringClassPtr; /* The class that declares this method, or
* NULL if it was declared directly on an
* object. */
int flags; /* Assorted flags. Includes whether this
* method is public/exported or not. */
};
/*
* Pre- and post-call callbacks, to allow procedure-like methods to be fine
* tuned in their behaviour.
*/
typedef int (TclOO_PreCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished);
typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
typedef void (TclOO_PmCDDeleteProc)(void *clientData);
typedef void *(TclOO_PmCDCloneProc)(void *clientData);
/*
* Procedure-like methods have the following extra information.
*/
struct ProcedureMethod {
int version; /* Version of this structure. Currently must
* be TCLOO_PROCEDURE_METHOD_VERSION_1. */
Proc *procPtr; /* Core of the implementation of the method;
* includes the argument definition and the
* body bytecodes. */
int flags; /* Flags to control features. */
Tcl_Size refCount;
void *clientData;
TclOO_PmCDDeleteProc *deleteClientdataProc;
TclOO_PmCDCloneProc *cloneClientdataProc;
ProcErrorProc *errProc; /* Replacement error handler. */
TclOO_PreCallProc *preCallProc;
/* Callback to allow for additional setup
* before the method executes. */
TclOO_PostCallProc *postCallProc;
/* Callback to allow for additional cleanup
* after the method executes. */
GetFrameInfoValueProc *gfivProc;
/* Callback to allow for fine tuning of how
* the method reports itself. */
Command cmd; /* Space used to connect to [info frame] */
ExtraFrameInfo efi; /* Space used to store data for [info frame] */
Tcl_Interp *interp; /* Interpreter in which to compute the name of
* the method. */
Tcl_Method method; /* Method to compute the name of. */
int callSiteFlags; /* Flags from the call chain. Only interested
* in whether this is a constructor or
* destructor, which we can't know until then
* for messy reasons. Other flags are variable
* but not used. */
};
enum ProcedureMethodVersion {
TCLOO_PROCEDURE_METHOD_VERSION_1 = 0
};
#define TCLOO_PROCEDURE_METHOD_VERSION TCLOO_PROCEDURE_METHOD_VERSION_1
/*
* Flags for use in a ProcedureMethod.
*
*/
enum ProceudreMethodFlags {
USE_DECLARER_NS = 0x80 /* When set, the method will use the namespace
* of the object or class that declared it (or
* the clone of it, if it was from such that
* the implementation of the method came to the
* particular use) instead of the namespace of
* the object on which the method was invoked.
* This flag must be distinct from all others
* that are associated with methods. */
};
/*
* Forwarded methods have the following extra information.
*/
struct ForwardMethod {
Tcl_Obj *prefixObj; /* The list of values to use to replace the
* object and method name with. Will be a
* non-empty list. */
};
/*
* Structure used in private variable mappings. Describes the mapping of a
* single variable from the user's local name to the system's storage name.
* [TIP #500]
*/
struct PrivateVariableMapping {
Tcl_Obj *variableObj; /* Name used within methods. This is the part
* that is properly under user control. */
Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */
};
/*
* Helper definitions that declare a "list" array. The two varieties are
* either optimized for simplicity (in the case that the whole array is
* typically assigned at once) or efficiency (in the case that the array is
* expected to be expanded over time). These lists are designed to be iterated
* over with the help of the FOREACH macro (see later in this file).
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 160 161 162 163 |
#define LIST_DYNAMIC(listType_t) \
struct { Tcl_Size num, size; listType_t *list; }
/*
* These types are needed in function arguments.
*/
typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
/*
| > > > > > | > < | < | < | | | | < < | | < | < | | | | | | 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 |
#define LIST_DYNAMIC(listType_t) \
struct { Tcl_Size num, size; listType_t *list; }
/*
* These types are needed in function arguments.
*/
typedef LIST_STATIC(Class *) ClassList;
typedef LIST_DYNAMIC(Class *) VarClassList;
typedef LIST_STATIC(Tcl_Obj *) FilterList;
typedef LIST_DYNAMIC(Object *) ObjectList;
typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
typedef LIST_STATIC(Tcl_Obj *) PropertyList;
/*
* This type is used in various places. It holds the parts of an object or
* class relating to property information.
*/
struct PropertyStorage {
PropertyList readable; /* The readable properties slot. */
PropertyList writable; /* The writable properties slot. */
Tcl_Obj *allReadableCache; /* The cache of all readable properties
* exposed by this object or class (in its
* stereotypical instancs). Contains a sorted
* unique list if not NULL. */
Tcl_Obj *allWritableCache; /* The cache of all writable properties
* exposed by this object or class (in its
* stereotypical instances). Contains a sorted
* unique list if not NULL. */
int epoch; /* The epoch that the caches are valid for. */
};
/*
* Now, the definition of what an object actually is.
*/
struct Object {
Foundation *fPtr; /* The basis for the object system, which is
* conceptually part of the interpreter. */
Tcl_Namespace *namespacePtr;/* This object's namespace. */
Tcl_Command command; /* Reference to this object's public
* command. */
Tcl_Command myCommand; /* Reference to this object's internal
* command. */
Class *selfCls; /* This object's class. */
Tcl_HashTable *methodsPtr; /* Object-local Tcl_Obj (method name) to
* Method* mapping. */
ClassList mixins; /* Classes mixed into this object. */
FilterList filters; /* List of filter names. */
Class *classPtr; /* This is non-NULL for all classes, and NULL
* for everything else. It points to the class
* structure. */
Tcl_Size refCount; /* Number of strong references to this object.
* Note that there may be many more weak
* references; this mechanism exists to
* avoid Tcl_Preserve. */
int flags; /* See ObjectFlags. */
Tcl_Size creationEpoch; /* Unique value to make comparisons of objects
* easier. */
Tcl_Size epoch; /* Per-object epoch, incremented when the way
* an object should resolve call chains is
* changed. */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
* the void *values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
/* Configurations for the variable resolver
* used inside methods. */
Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
* command. */
PropertyStorage properties; /* Information relating to the lists of
* properties that this object *claims* to
* support. */
| | > | | < | | | | | | | > | < | < | < | < | < | < | | | | 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 |
/* Configurations for the variable resolver
* used inside methods. */
Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
* command. */
PropertyStorage properties; /* Information relating to the lists of
* properties that this object *claims* to
* support. */
};
enum ObjectFlags {
OBJECT_DESTRUCTING = 1, /* Indicates that an object is being or has
* been destroyed */
DESTRUCTOR_CALLED = 2, /* Indicates that evaluation of destructor
* script for the object has began */
ROOT_OBJECT = 0x1000, /* Flag to say that this object is the root of
* the class hierarchy and should be treated
* specially during teardown. */
FILTER_HANDLING = 0x2000, /* Flag set when the object is processing a
* filter; when set, filters are *not*
* processed on the object, preventing nasty
* recursive filtering problems. */
USE_CLASS_CACHE = 0x4000, /* Flag set to say that the object is a pure
* instance of the class, and has had nothing
* added that changes the dispatch chain (i.e.
* no methods, mixins, or filters. */
ROOT_CLASS = 0x8000, /* Flag to say that this object is the root
* class of classes, and should be treated
* specially during teardown (and in a few
* other spots). */
FORCE_UNKNOWN = 0x10000, /* States that we are *really* looking up the
* unknown method handler at that point. */
DONT_DELETE = 0x20000, /* Inhibit deletion of this object. Used
* during fundamental object type mutation to
* make sure that the object actually survives
* to the end of the operation. */
HAS_PRIVATE_METHODS = 0x40000
/* Object/class has (or had) private methods,
* and so shouldn't be cached so
* aggressively. */
};
/*
* And the definition of a class. Note that every class also has an associated
* object, through which it is manipulated.
*/
struct Class {
Object *thisPtr; /* Reference to the object associated with
* this class. */
int flags; /* Assorted flags. */
ClassList superclasses; /* List of superclasses, used for generation
* of method call chains. */
VarClassList subclasses; /* List of subclasses, used to ensure deletion
* of dependent entities happens properly when
* the class itself is deleted. */
ObjectList instances; /* List of instances, used to ensure deletion
* of dependent entities happens properly when
* the class itself is deleted. */
FilterList filters; /* List of filter names, used for generation
* of method call chains. */
ClassList mixins; /* List of mixin classes, used for generation
* of method call chains. */
VarClassList mixinSubs; /* List of classes that this class is mixed
* into, used to ensure deletion of dependent
* entities happens properly when the class
* itself is deleted. */
Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from
* the (Tcl_Obj*) method name to the (Method*)
* method record. */
Method *constructorPtr; /* Method record of the class constructor (if
* any). */
Method *destructorPtr; /* Method record of the class destructor (if
* any). */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
* the void *values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
CallChain *constructorChainPtr;
CallChain *destructorChainPtr;
Tcl_HashTable *classChainCache;
/* Places where call chains are stored. For
* constructors, the class chain is always
* used. For destructors and ordinary methods,
* the class chain is only used when the
* object doesn't override with its own mixins
* (and filters and method implementations for
|
| ︙ | ︙ | |||
341 342 343 344 345 346 347 |
* [oo::objdefine]/[self] call time if this
* namespace is defined but doesn't exist; we
* also check at setting time but don't check
* between times. */
PropertyStorage properties; /* Information relating to the lists of
* properties that this class *claims* to
* support. */
| | | < < | < > > > > > > | | < < < < < < < < > > > | < < < | > < > > > > > > > | | | | > > > > > > | | | | | | | | < | > | < | | > > > > | | | | | | | | | | < < < < > > > > > > | > > > > > > > > > > > > > > > | 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 |
* [oo::objdefine]/[self] call time if this
* namespace is defined but doesn't exist; we
* also check at setting time but don't check
* between times. */
PropertyStorage properties; /* Information relating to the lists of
* properties that this class *claims* to
* support. */
};
/*
* Master epoch counter for making unique IDs for objects that can be compared
* cheaply.
*/
typedef struct ThreadLocalData {
Tcl_Size nsCount; /* Epoch counter is used for keeping
* the values used in Tcl_Obj internal
* representations sane. Must be thread-local
* because Tcl_Objs can cross interpreter
* boundaries within a thread (objects don't
* generally cross threads). */
} ThreadLocalData;
/*
* The foundation of the object system within an interpreter contains
* references to the key classes and namespaces, together with a few other
* useful bits and pieces. Probably ought to eventually go in the Interp
* structure itself.
*/
struct Foundation {
Tcl_Interp *interp; /* The interpreter this is attached to. */
Class *objectCls; /* The root of the object system. */
Class *classCls; /* The class of all classes. */
Tcl_Namespace *ooNs; /* ::oo namespace. */
Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
* only valid when executing inside a
* procedural method. */
Tcl_Size epoch; /* Used to invalidate method chains when the
* class structure changes. */
ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique
* namespace to each object. */
Tcl_Obj *unknownMethodNameObj;
/* Shared object containing the name of the
* unknown method handler method. */
Tcl_Obj *constructorName; /* Shared object containing the "name" of a
* constructor. */
Tcl_Obj *destructorName; /* Shared object containing the "name" of a
* destructor. */
Tcl_Obj *clonedName; /* Shared object containing the name of a
* "<cloned>" pseudo-constructor. */
Tcl_Obj *defineName; /* Fully qualified name of oo::define. */
Tcl_Obj *myName; /* The "my" shared object. */
Tcl_Obj *mcdName; /* The shared object for calling the helper to
* mix in class delegates. */
};
/*
* The number of MInvoke records in the CallChain before we allocate
* separately.
*/
#define CALL_CHAIN_STATIC_SIZE 4
/*
* Information relating to the invocation of a particular method implementation
* in a call chain.
*/
struct MInvoke {
Method *mPtr; /* Reference to the method implementation
* record. */
int isFilter; /* Whether this is a filter invocation. */
Class *filterDeclarer; /* What class decided to add the filter; if
* NULL, it was added by the object. */
};
/*
* The cacheable part of a call context.
*/
struct CallChain {
Tcl_Size objectCreationEpoch;/* The object's creation epoch. Note that the
* object reference is not stored in the call
* chain; it is in the call context. */
Tcl_Size objectEpoch; /* Local (object structure) epoch counter
* snapshot. */
Tcl_Size epoch; /* Global (class structure) epoch counter
* snapshot. */
int flags; /* Assorted flags, see below. */
Tcl_Size refCount; /* Reference count. */
Tcl_Size numChain; /* Size of the call chain. */
MInvoke *chain; /* Array of call chain entries. May point to
* staticChain if the number of entries is
* small. */
MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
};
/*
* A call context structure is built when a method is called. It contains the
* chain of method implementations that are to be invoked by a particular
* call, and the process of calling walks the chain, with the [next] command
* proceeding to the next entry in the chain.
*/
struct CallContext {
Object *oPtr; /* The object associated with this call. */
Tcl_Size index; /* Index into the call chain of the currently
* executing method implementation. */
Tcl_Size skip; /* Current number of arguments to skip; can
* vary depending on whether it is a direct
* method call or a continuation via the
* [next] command. */
CallChain *callPtr; /* The actual call chain. */
};
/*
* Bits for the 'flags' field of the call chain.
*/
enum TclOOCallChainFlags {
PUBLIC_METHOD = 0x01, /* This is a public (exported) method. */
PRIVATE_METHOD = 0x02, /* This is a private (class's direct instances
* only) method. Supports itcl. */
OO_UNKNOWN_METHOD = 0x04, /* This is an unknown method. */
CONSTRUCTOR = 0x08, /* This is a constructor. */
DESTRUCTOR = 0x10, /* This is a destructor. */
TRUE_PRIVATE_METHOD = 0x20 /* This is a private method only accessible
* from other methods defined on this class
* or instance. [TIP #500] */
};
#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)
/*
* Structure containing definition information about basic class methods.
*/
struct DeclaredClassMethod {
const char *name; /* Name of the method in question. */
int isPublic; /* Whether the method is public by default. */
Tcl_MethodType definition; /* How to call the method. */
};
/*
*----------------------------------------------------------------
* Commands relating to OO support.
*----------------------------------------------------------------
*/
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePropertyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition;
MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOInfoObjectPropCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOInfoClassPropCmd;
/*
* Method implementations (in tclOOBasic.c).
*/
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Constructor;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Create;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_CreateNs;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_New;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Destroy;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Eval;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_LinkVar;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Unknown;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_VarName;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Configurable_Configure;
/*
* Private definitions, some of which perhaps ought to be exposed properly or
* maybe just put in the internal stubs table.
*/
MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr);
MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
int flags, const Tcl_MethodType *typePtr,
void *clientData);
MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Class cls,
Tcl_Obj *nameObj, int flags,
const Tcl_MethodType *typePtr,
void *clientData);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, Tcl_Size objc,
Tcl_Obj *const *objv, Tcl_Size skip,
Tcl_Object *objectPtr);
MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp,
Class *classPtr,
const char *nameStr,
const char *nsNameStr);
MODULE_SCOPE int TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int TclOOObjectDestroyed(Object *oPtr);
MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp,
Object *oPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
Object *contextObjPtr, Class *contextClsPtr,
Tcl_Obj *cacheInThisObj);
MODULE_SCOPE Class * TclOOGetClassDefineCmdContext(Tcl_Interp *interp);
MODULE_SCOPE Class * TclOOGetClassFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE size_t TclOOGetSortedClassMethodList(Class *clsPtr,
int flags, const char ***stringsPtr);
MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr,
Object *contextObj, Class *contextCls, int flags,
const char ***stringsPtr);
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int TclOOInvokeContext(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Var TclOOLookupObjectVar(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *varName,
Tcl_Var *aryPtr);
MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_Size objc,
Tcl_Obj *const *objv, Tcl_Size skip);
MODULE_SCOPE void TclOODefineBasicMethods(Class *clsPtr,
const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp,
Object *oPtr);
MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE int TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr);
MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr,
Class *mixinPtr);
MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr,
Class *superPtr);
MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp,
CallChain *callPtr);
MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
CallContext *contextPtr);
MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr,
int writable);
MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
MODULE_SCOPE Tcl_Obj * TclOOGetPropertyList(PropertyList *propList);
MODULE_SCOPE void TclOOReleasePropertyStorage(PropertyStorage *propsPtr);
MODULE_SCOPE void TclOOInstallReadableProperties(PropertyStorage *props,
Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void TclOOInstallWritableProperties(PropertyStorage *props,
Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int TclOOInstallStdPropertyImpls(void *useInstance,
Tcl_Interp *interp, Tcl_Obj *propName,
int readable, int writable);
MODULE_SCOPE void TclOORegisterProperty(Class *clsPtr,
Tcl_Obj *propName, int mayRead, int mayWrite);
MODULE_SCOPE void TclOORegisterInstanceProperty(Object *oPtr,
Tcl_Obj *propName, int mayRead, int mayWrite);
/*
* Include all the private API, generated from tclOO.decls.
*/
#include "tclOOIntDecls.h"
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
#define FOREACH_STRUCT(var,ary) \
if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
* sets up the declarations needed for the main macro, FOREACH_HASH, which
| | | | | | > | > > > > | | > | > > > > > > | 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 |
#define FOREACH_STRUCT(var,ary) \
if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
* sets up the declarations needed for the main macro, FOREACH_HASH, which
* does the actual iteration. FOREACH_HASH_KEY and FOREACH_HASH_VALUE are
* restricted versions that only iterate over keys or values respectively.
* REQUIRES DECLARATION: FOREACH_HASH_DECLS;
*/
#define FOREACH_HASH_DECLS \
Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key, val, tablePtr) \
for(hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \
(*(void **)&(key) = Tcl_GetHashKey((tablePtr), hPtr), \
*(void **)&(val) = Tcl_GetHashValue(hPtr), 1) : 0; \
hPtr = Tcl_NextHashEntry(&search))
#define FOREACH_HASH_KEY(key, tablePtr) \
for(hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \
(*(void **)&(key) = Tcl_GetHashKey((tablePtr), hPtr), 1) : 0; \
hPtr = Tcl_NextHashEntry(&search))
#define FOREACH_HASH_VALUE(val, tablePtr) \
for(hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \
(*(void **)&(val) = Tcl_GetHashValue(hPtr), 1) : 0; \
hPtr = Tcl_NextHashEntry(&search))
/*
* Convenience macro for duplicating a list. Needs no external declaration,
* but all arguments are used multiple times and so must have no side effects.
*/
#undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */
#define DUPLICATE(target,source,type) \
do { \
size_t len = sizeof(type) * ((target).num=(source).num);\
if (len != 0) { \
memcpy(((target).list=(type*)Tcl_Alloc(len)), (source).list, len); \
} else { \
(target).list = NULL; \
} \
} while(0)
/*
* Convenience macro for generating error codes.
*/
#define OO_ERROR(interp, code) \
Tcl_SetErrorCode((interp), "TCL", "OO", #code, (char *)NULL)
#endif /* TCL_OO_INTERNAL_H */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclOOIntDecls.h.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
/* 14 */
TCLAPI void TclOOObjectSetMixins(Object *oPtr,
Tcl_Size numMixins, Class *const *mixins);
/* 15 */
TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp,
Class *classPtr, Tcl_Size numMixins,
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */
| > > > > > > > > > > > > > | 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 |
/* 14 */
TCLAPI void TclOOObjectSetMixins(Object *oPtr,
Tcl_Size numMixins, Class *const *mixins);
/* 15 */
TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp,
Class *classPtr, Tcl_Size numMixins,
Class *const *mixins);
/* 16 */
TCLAPI Tcl_Method TclOOMakeProcInstanceMethod2(Tcl_Interp *interp,
Object *oPtr, int flags, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
const Tcl_MethodType2 *typePtr,
void *clientData, Proc **procPtrPtr);
/* 17 */
TCLAPI Tcl_Method TclOOMakeProcMethod2(Tcl_Interp *interp,
Class *clsPtr, int flags, Tcl_Obj *nameObj,
const char *namePtr, Tcl_Obj *argsObj,
Tcl_Obj *bodyObj,
const Tcl_MethodType2 *typePtr,
void *clientData, Proc **procPtrPtr);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */
Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */
int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, Tcl_Size objc, Tcl_Obj *const *objv); /* 11 */
void (*tclOOObjectSetFilters) (Object *oPtr, Tcl_Size numFilters, Tcl_Obj *const *filters); /* 12 */
void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, Tcl_Size numFilters, Tcl_Obj *const *filters); /* 13 */
void (*tclOOObjectSetMixins) (Object *oPtr, Tcl_Size numMixins, Class *const *mixins); /* 14 */
void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, Tcl_Size numMixins, Class *const *mixins); /* 15 */
} TclOOIntStubs;
extern const TclOOIntStubs *tclOOIntStubsPtr;
#ifdef __cplusplus
}
#endif
| > > | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */
Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */
int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, Tcl_Size objc, Tcl_Obj *const *objv); /* 11 */
void (*tclOOObjectSetFilters) (Object *oPtr, Tcl_Size numFilters, Tcl_Obj *const *filters); /* 12 */
void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, Tcl_Size numFilters, Tcl_Obj *const *filters); /* 13 */
void (*tclOOObjectSetMixins) (Object *oPtr, Tcl_Size numMixins, Class *const *mixins); /* 14 */
void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, Tcl_Size numMixins, Class *const *mixins); /* 15 */
Tcl_Method (*tclOOMakeProcInstanceMethod2) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType2 *typePtr, void *clientData, Proc **procPtrPtr); /* 16 */
Tcl_Method (*tclOOMakeProcMethod2) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType2 *typePtr, void *clientData, Proc **procPtrPtr); /* 17 */
} TclOOIntStubs;
extern const TclOOIntStubs *tclOOIntStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 161 162 163 164 165 166 | (tclOOIntStubsPtr->tclOOObjectSetFilters) /* 12 */ #define TclOOClassSetFilters \ (tclOOIntStubsPtr->tclOOClassSetFilters) /* 13 */ #define TclOOObjectSetMixins \ (tclOOIntStubsPtr->tclOOObjectSetMixins) /* 14 */ #define TclOOClassSetMixins \ (tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLOOINTDECLS */ | > > > > | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | (tclOOIntStubsPtr->tclOOObjectSetFilters) /* 12 */ #define TclOOClassSetFilters \ (tclOOIntStubsPtr->tclOOClassSetFilters) /* 13 */ #define TclOOObjectSetMixins \ (tclOOIntStubsPtr->tclOOObjectSetMixins) /* 14 */ #define TclOOClassSetMixins \ (tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */ #define TclOOMakeProcInstanceMethod2 \ (tclOOIntStubsPtr->tclOOMakeProcInstanceMethod2) /* 16 */ #define TclOOMakeProcMethod2 \ (tclOOIntStubsPtr->tclOOMakeProcMethod2) /* 17 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLOOINTDECLS */ |
Changes to generic/tclOOMethod.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" | < < < < < < < < < < < | | < < < | < < | | 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 |
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
/*
* Structure used to contain all the information needed about a call frame
* used in a procedure-like method.
*/
typedef struct PMFrameData {
CallFrame *framePtr; /* Reference to the call frame itself (it's
* actually allocated on the Tcl stack). */
ProcErrorProc *errProc; /* The error handler for the body. */
Tcl_Obj *nameObj; /* The "name" of the command. Only used for a
* few moments, so not reference. */
} PMFrameData;
/*
* Structure used to pass information about variable resolution to the
* on-the-ground resolvers used when working with resolved compiled variables.
*/
typedef struct OOResVarInfo {
Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled
* variable can be linked to the namespace
* variable at the right time. */
Tcl_Obj *variableObj; /* The name of the variable. */
Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class
* variables be cached? */
} OOResVarInfo;
|
| ︙ | ︙ | |||
79 80 81 82 83 84 85 86 87 88 89 90 91 92 | static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, void *clientData, void **newClientData); static ProcErrorProc MethodErrorHandler; static ProcErrorProc ConstructorErrorHandler; static ProcErrorProc DestructorErrorHandler; static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, void *clientData, void **newClientData); | > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, void *clientData, void **newClientData); static ProcErrorProc MethodErrorHandler; static ProcErrorProc ConstructorErrorHandler; static ProcErrorProc DestructorErrorHandler; static Tcl_Obj * RenderMethodName(void *clientData); static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, void *clientData, void **newClientData); |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
* Helper macros (derived from things private to tclVar.c)
*/
#define TclVarTable(contextNs) \
((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
/*
* ----------------------------------------------------------------------
*
* Tcl_NewInstanceMethod --
*
* Attach a method to an object instance.
| > > > > > > > > > > > > > > | 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 |
* Helper macros (derived from things private to tclVar.c)
*/
#define TclVarTable(contextNs) \
((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
static inline ProcedureMethod *
AllocProcedureMethodRecord(
int flags)
{
ProcedureMethod *pmPtr = (ProcedureMethod *)
Tcl_Alloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
pmPtr->cmd.clientData = &pmPtr->efi;
return pmPtr;
}
/*
* ----------------------------------------------------------------------
*
* Tcl_NewInstanceMethod --
*
* Attach a method to an object instance.
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
{
Object *oPtr = (Object *) object;
Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
| | | | | | 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 |
{
Object *oPtr = (Object *) object;
Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, nameObj, &isNew);
if (isNew) {
mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->namePtr = nameObj;
mPtr->refCount = 1;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
}
populate:
mPtr->typePtr = typePtr;
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
| | > | | | > | < | | | | | 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 |
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"Tcl_NewInstanceMethod", "TCL_OO_METHOD_VERSION_1");
}
return TclNewInstanceMethod(NULL, object, nameObj, flags, typePtr,
clientData);
}
Tcl_Method
Tcl_NewInstanceMethod2(
TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
* up to caller to manage storage (e.g., when
* it is a constructor or destructor). */
int flags, /* Whether this is a public method. */
const Tcl_MethodType2 *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"Tcl_NewInstanceMethod2", "TCL_OO_METHOD_VERSION_2");
}
return TclNewInstanceMethod(NULL, object, nameObj, flags,
(const Tcl_MethodType *) typePtr, clientData);
}
/*
* ----------------------------------------------------------------------
*
* Tcl_NewMethod --
*
* Attach a method to a class.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
TclNewMethod(
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
* to caller to manage storage. */
int flags, /* Whether this is a public method. */
const Tcl_MethodType *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
Class *clsPtr = (Class *) cls;
Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj, &isNew);
if (isNew) {
mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = nameObj;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
}
populate:
clsPtr->thisPtr->fPtr->epoch++;
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
| | > | | > > | | 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 |
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"Tcl_NewMethod", "TCL_OO_METHOD_VERSION_1");
}
return TclNewMethod(cls, nameObj, flags, typePtr, clientData);
}
Tcl_Method
Tcl_NewMethod2(
TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
* to caller to manage storage. */
int flags, /* Whether this is a public method. */
const Tcl_MethodType2 *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"Tcl_NewMethod2", "TCL_OO_METHOD_VERSION_2");
}
return TclNewMethod(cls, nameObj, flags,
(const Tcl_MethodType *) typePtr, clientData);
}
/*
* ----------------------------------------------------------------------
*
* TclOODelMethodRef --
*
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
Tcl_Free(mPtr);
}
}
/*
* ----------------------------------------------------------------------
*
| | | < | | | > | | > | < | | > | > | 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 |
Tcl_Free(mPtr);
}
}
/*
* ----------------------------------------------------------------------
*
* TclOODefineBasicMethods --
*
* Helper that makes it cleaner to create very simple methods during
* basic system initialization. Not suitable for general use.
*
* ----------------------------------------------------------------------
*/
void
TclOODefineBasicMethods(
Class *clsPtr, /* Class to attach the methods to. */
const DeclaredClassMethod *dcmAry)
/* Static table of method definitions. */
{
int i;
for (i = 0 ; dcmAry[i].name ; i++) {
Tcl_Obj *namePtr = Tcl_NewStringObj(dcmAry[i].name, TCL_AUTO_LENGTH);
TclNewMethod((Tcl_Class) clsPtr, namePtr,
(dcmAry[i].isPublic ? PUBLIC_METHOD : 0),
&dcmAry[i].definition, NULL);
Tcl_BounceRefCount(namePtr);
}
}
/*
* ----------------------------------------------------------------------
*
* TclOONewProcInstanceMethod --
*
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 |
* structure's contents. NULL if caller is not
* interested. */
{
Tcl_Size argsLen;
ProcedureMethod *pmPtr;
Tcl_Method method;
| | < < < < < | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
* structure's contents. NULL if caller is not
* interested. */
{
Tcl_Size argsLen;
ProcedureMethod *pmPtr;
Tcl_Method method;
if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
pmPtr = AllocProcedureMethodRecord(flags);
method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (method == NULL) {
Tcl_Free(pmPtr);
} else if (pmPtrPtr != NULL) {
*pmPtrPtr = pmPtr;
}
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
Tcl_Method method;
if (argsObj == NULL) {
argsLen = TCL_INDEX_NONE;
TclNewObj(argsObj);
Tcl_IncrRefCount(argsObj);
procName = "<destructor>";
| | < < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
Tcl_Method method;
if (argsObj == NULL) {
argsLen = TCL_INDEX_NONE;
TclNewObj(argsObj);
Tcl_IncrRefCount(argsObj);
procName = "<destructor>";
} else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
}
pmPtr = AllocProcedureMethodRecord(flags);
method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (argsLen == TCL_INDEX_NONE) {
Tcl_DecrRefCount(argsObj);
}
if (method == NULL) {
Tcl_Free(pmPtr);
} else if (pmPtrPtr != NULL) {
*pmPtrPtr = pmPtr;
}
return (Method *) method;
}
/*
* ----------------------------------------------------------------------
*
* InitCmdFrame --
*
* Set up a CmdFrame to record the source location for a procedure
* method. Assumes that the body is the last argument to the command
* creating the method, a good assumption because putting the body
* elsewhere is ugly.
*
* ----------------------------------------------------------------------
*/
static inline void
InitCmdFrame(
Interp *iPtr, /* Where source locations are recorded. */
Proc *procPtr) /* Guts of the method being made. */
{
if (iPtr->cmdFramePtr) {
CmdFrame context = *iPtr->cmdFramePtr;
if (context.type == TCL_LOCATION_BC) {
/*
* Retrieve source information from the bytecode, if possible. If
* the information is retrieved successfully, context.type will be
* TCL_LOCATION_SOURCE and the reference held by
* context.data.eval.path will be counted.
*/
TclGetSrcInfoForPc(&context);
} else if (context.type == TCL_LOCATION_SOURCE) {
/*
* The copy into 'context' up above has created another reference
* to 'context.data.eval.path'; account for it.
*/
Tcl_IncrRefCount(context.data.eval.path);
}
if (context.type == TCL_LOCATION_SOURCE) {
/*
* We can account for source location within a proc only if the
* proc body was not created by substitution. This is where we
* assume that the body is the last argument; the index of the body
* is NOT a fixed count of arguments in because of the alternate
* form of [oo::define]/[oo::objdefine].
* (FIXME: check that this is sane and correct!)
*/
if (context.line && context.nline > 1
&& (context.line[context.nline - 1] >= 0)) {
int isNew;
CmdFrame *cfPtr = (CmdFrame *) Tcl_Alloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = (Tcl_Size *) Tcl_Alloc(sizeof(Tcl_Size));
cfPtr->line[0] = context.line[context.nline - 1];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
cfPtr->cmd = NULL;
cfPtr->len = 0;
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
procPtr, &isNew);
Tcl_SetHashValue(hPtr, cfPtr);
}
/*
* 'context' is going out of scope; account for the reference that
* it's holding to the path name.
*/
Tcl_DecrRefCount(context.data.eval.path);
context.data.eval.path = NULL;
}
}}
/*
* ----------------------------------------------------------------------
*
* TclOOMakeProcInstanceMethod --
*
* The guts of the code to make a procedure-like method for an object.
* Split apart so that it is easier for other extensions to reuse (in
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
* NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which _must not_ be NULL. */
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 |
* NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which _must not_ be NULL. */
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
* pointer in clientData. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"TclOOMakeProcInstanceMethod", "TCL_OO_METHOD_VERSION_1");
}
if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
procPtrPtr) != TCL_OK) {
return NULL;
}
procPtr = *procPtrPtr;
procPtr->cmdPtr = NULL;
InitCmdFrame(iPtr, procPtr);
return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
typePtr, clientData);
}
Tcl_Method
TclOOMakeProcInstanceMethod2(
Tcl_Interp *interp, /* The interpreter containing the object. */
Object *oPtr, /* The object to modify. */
int flags, /* Whether this is a public method. */
Tcl_Obj *nameObj, /* The name of the method, which _must not_ be
* NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which _must not_ be NULL. */
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
* NULL. */
const Tcl_MethodType2 *typePtr,
/* The type of the method to create. */
void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
* pointer in clientData. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"TclOOMakeProcInstanceMethod2", "TCL_OO_METHOD_VERSION_2");
}
if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
procPtrPtr) != TCL_OK) {
return NULL;
}
procPtr = *procPtrPtr;
procPtr->cmdPtr = NULL;
InitCmdFrame(iPtr, procPtr);
return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
(const Tcl_MethodType *)typePtr, clientData);
}
/*
* ----------------------------------------------------------------------
*
* TclOOMakeProcMethod --
*
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
* _must not_ be NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which _must not_ be NULL. */
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
* _must not_ be NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which _must not_ be NULL. */
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
* pointer in clientData. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"TclOOMakeProcMethod", "TCL_OO_METHOD_VERSION_1");
}
if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj,
procPtrPtr) != TCL_OK) {
return NULL;
}
procPtr = *procPtrPtr;
procPtr->cmdPtr = NULL;
InitCmdFrame(iPtr, procPtr);
return TclNewMethod(
(Tcl_Class) clsPtr, nameObj, flags, typePtr, clientData);
}
Tcl_Method
TclOOMakeProcMethod2(
Tcl_Interp *interp, /* The interpreter containing the class. */
Class *clsPtr, /* The class to modify. */
int flags, /* Whether this is a public method. */
Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
* if so, up to caller to manage storage
* (e.g., because it is a constructor or
* destructor). */
const char *namePtr, /* The name of the method as a string, which
* _must not_ be NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which _must not_ be NULL. */
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
* NULL. */
const Tcl_MethodType2 *typePtr,
/* The type of the method to create. */
void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
* pointer in clientData. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"TclOOMakeProcMethod2", "TCL_OO_METHOD_VERSION_2");
}
if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj,
procPtrPtr) != TCL_OK) {
return NULL;
}
procPtr = *procPtrPtr;
procPtr->cmdPtr = NULL;
InitCmdFrame(iPtr, procPtr);
return TclNewMethod(
(Tcl_Class) clsPtr, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData);
}
/*
* ----------------------------------------------------------------------
*
* InvokeProcedureMethod, PushMethodCallFrame --
*
* How to invoke a procedure-like method.
*
* ----------------------------------------------------------------------
*/
static int
InvokeProcedureMethod(
void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
int result;
PMFrameData *fdPtr; /* Important data that has to have a lifetime
* matched by this function (or rather, by the
* call frame's lifetime). */
/*
* If the object namespace (or interpreter) were deleted, we just skip to
* the next thing in the chain.
*/
if (TclOOObjectDestroyed(((CallContext *) context)->oPtr)
|| Tcl_InterpDeleted(interp)) {
return TclNRObjectContextInvokeNext(interp, context, objc, objv,
Tcl_ObjectContextSkippedArgs(context));
}
/*
* Finishes filling out the extra frame info so that [info frame] works if
* that is not already set up.
*/
if (pmPtr->efi.length == 0) {
Tcl_Method method = Tcl_ObjectContextMethod(context);
pmPtr->efi.length = 2;
pmPtr->efi.fields[0].name = "method";
pmPtr->efi.fields[0].proc = RenderMethodName;
pmPtr->efi.fields[0].clientData = pmPtr;
pmPtr->callSiteFlags = ((CallContext *)
context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR);
pmPtr->interp = interp;
pmPtr->method = method;
if (pmPtr->gfivProc != NULL) {
pmPtr->efi.fields[1].name = "";
pmPtr->efi.fields[1].proc = pmPtr->gfivProc;
pmPtr->efi.fields[1].clientData = pmPtr;
} else {
if (Tcl_MethodDeclarerObject(method) != NULL) {
pmPtr->efi.fields[1].name = "object";
} else {
pmPtr->efi.fields[1].name = "class";
}
pmPtr->efi.fields[1].proc = RenderDeclarerName;
pmPtr->efi.fields[1].clientData = pmPtr;
}
}
/*
* Allocate the special frame data.
*/
fdPtr = (PMFrameData *) TclStackAlloc(interp, sizeof(PMFrameData));
/*
* Create a call frame for this method.
*/
result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
objc, objv, fdPtr);
|
| ︙ | ︙ | |||
793 794 795 796 797 798 799 |
if (pmPtr->preCallProc != NULL) {
int isFinished;
result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
if (isFinished || result != TCL_OK) {
| < < < < < < < | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
if (pmPtr->preCallProc != NULL) {
int isFinished;
result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
if (isFinished || result != TCL_OK) {
Tcl_PopCallFrame(interp);
TclStackFree(interp, fdPtr->framePtr);
if (pmPtr->refCount-- <= 1) {
DeleteProcedureMethodRecord(pmPtr);
}
TclStackFree(interp, fdPtr);
return result;
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
static int
FinalizePMCall(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | < < < < < < < | 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 |
static int
FinalizePMCall(
void *data[],
Tcl_Interp *interp,
int result)
{
ProcedureMethod *pmPtr = (ProcedureMethod *) data[0];
Tcl_ObjectContext context = (Tcl_ObjectContext) data[1];
PMFrameData *fdPtr = (PMFrameData *) data[2];
/*
* Give the post-call callback a chance to do some cleanup. Note that at
* this point the call frame itself is invalid; it's already been popped.
*/
if (pmPtr->postCallProc) {
result = pmPtr->postCallProc(pmPtr->clientData, interp, context,
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),
result);
}
/*
* Scrap the special frame data now that we're done with it. Note that we
* are inlining DeleteProcedureMethod() here; this location is highly
* sensitive when it comes to performance!
*/
if (pmPtr->refCount-- <= 1) {
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 |
int objc, /* Number of arguments. */
Tcl_Obj *const *objv, /* Array of arguments. */
PMFrameData *fdPtr) /* Place to store information about the call
* frame. */
{
Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
int result;
| < < < < < | < < < < < < < < | < | < < < < < < < > | > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
int objc, /* Number of arguments. */
Tcl_Obj *const *objv, /* Array of arguments. */
PMFrameData *fdPtr) /* Place to store information about the call
* frame. */
{
Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
int result;
CallFrame **framePtrPtr = &fdPtr->framePtr;
ByteCode *codePtr;
/*
* Compute basic information on the basis of the type of method it is.
*/
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName;
fdPtr->errProc = ConstructorErrorHandler;
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName;
fdPtr->errProc = DestructorErrorHandler;
} else {
fdPtr->nameObj = Tcl_MethodName(
Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr));
fdPtr->errProc = MethodErrorHandler;
}
if (pmPtr->errProc != NULL) {
fdPtr->errProc = pmPtr->errProc;
}
/*
* Magic to enable things like [incr Tcl], which wants methods to run in
* their class's namespace.
*/
if (pmPtr->flags & USE_DECLARER_NS) {
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
if (mPtr->declaringClassPtr != NULL) {
nsPtr = (Namespace *)
mPtr->declaringClassPtr->thisPtr->namespacePtr;
} else {
nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr;
}
}
/*
* Compile the body.
*
* [Bug 2037727] Always call TclProcCompileProc so that we check not only
* that we have bytecode, but also that it remains valid. Note that we set
* the namespace of the code here directly; this is a hack, but the
* alternative is *so* slow...
*/
pmPtr->procPtr->cmdPtr = &pmPtr->cmd;
ByteCodeGetInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr);
if (codePtr) {
codePtr->nsPtr = nsPtr;
}
result = TclProcCompileProc(interp, pmPtr->procPtr,
pmPtr->procPtr->bodyPtr, nsPtr, "body of method",
TclGetString(fdPtr->nameObj));
if (result != TCL_OK) {
return result;
}
/*
* Make the stack frame and fill it out with information about this call.
* This operation doesn't ever actually fail.
*/
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
(Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD);
fdPtr->framePtr->clientData = contextPtr;
fdPtr->framePtr->objc = objc;
fdPtr->framePtr->objv = objv;
fdPtr->framePtr->procPtr = pmPtr->procPtr;
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOSetupVariableResolver, etc. --
*
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
}
static int
ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
| | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
}
static int
ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
TCL_UNUSED(int) /*flags*/, // Ignoring variable access flags (???)
Tcl_Var *varPtr)
{
int result;
Tcl_ResolvedVarInfo *rPtr = NULL;
result = ProcedureMethodCompiledVarResolver(interp, varName,
strlen(varName), contextNs, &rPtr);
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 |
* method call; if not (i.e. we're evaluating in the object's namespace or
* in a procedure of that namespace) then we do nothing.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return NULL;
}
| | | 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
* method call; if not (i.e. we're evaluating in the object's namespace or
* in a procedure of that namespace) then we do nothing.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return NULL;
}
contextPtr = (CallContext *) framePtr->clientData;
/*
* If we've done the work before (in a comparable context) then reuse that
* rather than performing resolution ourselves.
*/
if (infoPtr->cachedObjectVar) {
|
| ︙ | ︙ | |||
1202 1203 1204 1205 1206 1207 1208 |
if (strstr(TclGetString(variableObj), "::") != NULL ||
Tcl_StringMatch(TclGetString(variableObj), "*(*)")) {
Tcl_DecrRefCount(variableObj);
return TCL_CONTINUE;
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < | < < < < < < < < < < | < < < < < < < < < < < < | < < < < < < < < < < | < < < < < < < < < < < | < < < < < < < < < < | < < < < < | 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 |
if (strstr(TclGetString(variableObj), "::") != NULL ||
Tcl_StringMatch(TclGetString(variableObj), "*(*)")) {
Tcl_DecrRefCount(variableObj);
return TCL_CONTINUE;
}
infoPtr = (OOResVarInfo *) Tcl_Alloc(sizeof(OOResVarInfo));
infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
infoPtr->cachedObjectVar = NULL;
infoPtr->variableObj = variableObj;
Tcl_IncrRefCount(variableObj);
*rPtrPtr = &infoPtr->info;
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* RenderMethodName --
*
* Returns the name of the declared method. Used for producing information
* for [info frame].
*
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
RenderMethodName(
void *clientData)
{
ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
if (pmPtr->callSiteFlags & CONSTRUCTOR) {
return TclOOGetFoundation(pmPtr->interp)->constructorName;
} else if (pmPtr->callSiteFlags & DESTRUCTOR) {
return TclOOGetFoundation(pmPtr->interp)->destructorName;
} else {
return Tcl_MethodName(pmPtr->method);
}
}
/*
* ----------------------------------------------------------------------
*
* RenderDeclarerName --
*
* Returns the name of the entity (object or class) which declared a
* method. Used for producing information for [info frame] in such a way
* that the expensive part of this (generating the object or class name
* itself) isn't done until it is needed.
*
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
RenderDeclarerName(
void *clientData)
{
ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
Tcl_Object object = Tcl_MethodDeclarerObject(pmPtr->method);
if (object == NULL) {
object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pmPtr->method));
}
return TclOOObjectName(pmPtr->interp, (Object *) object);
}
/*
* ----------------------------------------------------------------------
*
* MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler --
*
* How to fill in the stack trace correctly upon error in various forms
* of procedure-like methods. LIMIT is how long the inserted strings in
* the error traces should get before being converted to have ellipses,
* and ELLIPSIFY is a macro to do the conversion (with the help of a
* %.*s%s format field). Note that ELLIPSIFY is only safe for use in
* suitable formatting contexts.
*
* ----------------------------------------------------------------------
*/
// TODO: Check whether Tcl_AppendLimitedToObj() can work here.
#define LIMIT 60
#define ELLIPSIFY(str,len) \
((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "")
static void
CommonMethErrorHandler(
Tcl_Interp *interp,
const char *special)
{
Tcl_Size objectNameLen;
CallContext *contextPtr = (CallContext *)((Interp *)
interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const char *objectName, *kindName = "instance";
Object *declarerPtr = NULL;
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
kindName = "object";
} else if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
kindName = "class";
}
if (declarerPtr) {
objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr),
&objectNameLen);
} else {
objectName = "unknown or deleted";
objectNameLen = 18;
}
if (!special) {
Tcl_Size nameLen;
const char *methodName = TclGetStringFromObj(mPtr->namePtr, &nameLen);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
kindName, ELLIPSIFY(objectName, objectNameLen),
ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
} else {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" %s line %d)",
kindName, ELLIPSIFY(objectName, objectNameLen), special,
Tcl_GetErrorLine(interp)));
}
}
static void
MethodErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
{
/* We pull the method name out of context instead of from argument. */
CommonMethErrorHandler(interp, NULL);
}
static void
ConstructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
{
/* We know this is for the constructor. */
CommonMethErrorHandler(interp, "constructor");
}
static void
DestructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
{
/* We know this is for the destructor. */
CommonMethErrorHandler(interp, "destructor");
}
/*
* ----------------------------------------------------------------------
*
* DeleteProcedureMethod, CloneProcedureMethod --
*
|
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
Tcl_Free(pmPtr);
}
static void
DeleteProcedureMethod(
void *clientData)
{
| | | | | 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
Tcl_Free(pmPtr);
}
static void
DeleteProcedureMethod(
void *clientData)
{
ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
if (pmPtr->refCount-- <= 1) {
DeleteProcedureMethodRecord(pmPtr);
}
}
static int
CloneProcedureMethod(
Tcl_Interp *interp,
void *clientData,
void **newClientData)
{
ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
ProcedureMethod *pm2Ptr;
Tcl_Obj *bodyObj, *argsObj;
CompiledLocal *localPtr;
/*
* Copy the argument list.
*/
TclNewObj(argsObj);
for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
Tcl_Obj *argObj;
TclNewObj(argObj);
Tcl_ListObjAppendElement(NULL, argObj,
Tcl_NewStringObj(localPtr->name, TCL_AUTO_LENGTH));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, argsObj, argObj);
}
}
|
| ︙ | ︙ | |||
1428 1429 1430 1431 1432 1433 1434 |
Tcl_StoreInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
* record.
*/
| | > > | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
Tcl_StoreInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
* record.
*/
pm2Ptr = (ProcedureMethod *) Tcl_Alloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
pm2Ptr->cmd.clientData = &pm2Ptr->efi;
pm2Ptr->efi.length = 0; /* Trigger a reinit of this. */
Tcl_IncrRefCount(argsObj);
Tcl_IncrRefCount(bodyObj);
if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
&pm2Ptr->procPtr) != TCL_OK) {
Tcl_DecrRefCount(argsObj);
Tcl_DecrRefCount(bodyObj);
Tcl_Free(pm2Ptr);
|
| ︙ | ︙ | |||
1472 1473 1474 1475 1476 1477 1478 |
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
Tcl_Size prefixLen;
ForwardMethod *fmPtr;
| | | | | | 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 |
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
Tcl_Size prefixLen;
ForwardMethod *fmPtr;
if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", TCL_AUTO_LENGTH));
OO_ERROR(interp, BAD_FORWARD);
return NULL;
}
fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
/*
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 |
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
Tcl_Size prefixLen;
ForwardMethod *fmPtr;
| | | | | | | | | | | | | | | | 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 |
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
Tcl_Size prefixLen;
ForwardMethod *fmPtr;
if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", TCL_AUTO_LENGTH));
OO_ERROR(interp, BAD_FORWARD);
return NULL;
}
fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) TclNewMethod((Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
/*
* ----------------------------------------------------------------------
*
* InvokeForwardMethod --
*
* How to invoke a forwarded method. Works by doing some ensemble-like
* command rearranging and then invokes some other Tcl command.
*
* ----------------------------------------------------------------------
*/
static int
InvokeForwardMethod(
void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
CallContext *contextPtr = (CallContext *) context;
ForwardMethod *fmPtr = (ForwardMethod *) clientData;
Tcl_Obj **argObjs, **prefixObjs;
Tcl_Size numPrefixes, skip = contextPtr->skip;
int len;
/*
* Build the real list of arguments to use. Note that we know that the
* prefixObj field of the ForwardMethod structure holds a reference to a
* non-empty list, so there's a whole class of failures ("not a list") we
* can ignore here.
*/
TclListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
numPrefixes, prefixObjs, &len);
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
/*
* NOTE: The combination of direct set of iPtr->lookupNsPtr and the use
* of the TCL_EVAL_NOERR flag results in an evaluation configuration
* very much like TCL_EVAL_INVOKE.
*/
((Interp *) interp)->lookupNsPtr = (Namespace *)
contextPtr->oPtr->namespacePtr;
return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
}
static int
FinalizeForwardCall(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **argObjs = (Tcl_Obj **) data[0];
TclStackFree(interp, argObjs);
return result;
}
/*
* ----------------------------------------------------------------------
*
* DeleteForwardMethod, CloneForwardMethod --
*
* How to delete and clone forwarded methods.
*
* ----------------------------------------------------------------------
*/
static void
DeleteForwardMethod(
void *clientData)
{
ForwardMethod *fmPtr = (ForwardMethod *) clientData;
Tcl_DecrRefCount(fmPtr->prefixObj);
Tcl_Free(fmPtr);
}
static int
CloneForwardMethod(
TCL_UNUSED(Tcl_Interp *),
void *clientData,
void **newClientData)
{
ForwardMethod *fmPtr = (ForwardMethod *) clientData;
ForwardMethod *fm2Ptr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
*newClientData = fm2Ptr;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1637 1638 1639 1640 1641 1642 1643 |
*/
Proc *
TclOOGetProcFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
| | | | | 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 |
*/
Proc *
TclOOGetProcFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = (ProcedureMethod *) mPtr->clientData;
return pmPtr->procPtr;
}
return NULL;
}
Tcl_Obj *
TclOOGetMethodBody(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = (ProcedureMethod *) mPtr->clientData;
(void) TclGetString(pmPtr->procPtr->bodyPtr);
return pmPtr->procPtr->bodyPtr;
}
return NULL;
}
Tcl_Obj *
TclOOGetFwdFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &fwdMethodType) {
ForwardMethod *fwPtr = (ForwardMethod *) mPtr->clientData;
return fwPtr->prefixObj;
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 |
int toRewrite, /* Number of real arguments to replace. */
int rewriteLength, /* Number of arguments to insert instead. */
Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
int *lengthPtr) /* Where to write the resulting length of the
* array of rewritten arguments. */
{
size_t len = rewriteLength + objc - toRewrite;
| | > | 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
int toRewrite, /* Number of real arguments to replace. */
int rewriteLength, /* Number of arguments to insert instead. */
Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
int *lengthPtr) /* Where to write the resulting length of the
* array of rewritten arguments. */
{
size_t len = rewriteLength + objc - toRewrite;
Tcl_Obj **argObjs = (Tcl_Obj **)
TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
memcpy(argObjs + rewriteLength, objv + toRewrite,
sizeof(Tcl_Obj *) * (objc - toRewrite));
/*
* Now plumb this into the core ensemble rewrite logging system so that
|
| ︙ | ︙ | |||
1781 1782 1783 1784 1785 1786 1787 |
Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr)
{
Method *mPtr = (Method *) method;
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
| | > | > | | | | 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 |
Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr)
{
Method *mPtr = (Method *) method;
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"Tcl_MethodIsType", "TCL_OO_METHOD_VERSION_1");
}
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
}
return 1;
}
return 0;
}
int
Tcl_MethodIsType2(
Tcl_Method method,
const Tcl_MethodType2 *typePtr,
void **clientDataPtr)
{
Method *mPtr = (Method *) method;
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
"Tcl_MethodIsType2", "TCL_OO_METHOD_VERSION_2");
}
if (mPtr->typePtr == (const Tcl_MethodType *) typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
}
return 1;
}
return 0;
}
int
Tcl_MethodIsPublic(
Tcl_Method method)
{
return (((Method *) method)->flags & PUBLIC_METHOD) ? 1 : 0;
}
int
Tcl_MethodIsPrivate(
Tcl_Method method)
{
return (((Method *) method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
}
/*
* Extended method construction for itcl-ng.
*/
Tcl_Method
|
| ︙ | ︙ |
Added generic/tclOOProp.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 |
/*
* tclOOProp.c --
*
* This file contains implementations of the configurable property
* mecnanisms.
*
* Copyright © 2023-2024 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclOOInt.h"
/* Short-term cache for GetPropertyName(). */
typedef struct GPNCache {
Tcl_Obj *listPtr; /* Holds references to names. */
char *names[TCLFLEXARRAY]; /* NULL-terminated table of names. */
} GPNCache;
enum GPNFlags {
GPN_WRITABLE = 1, /* Are we looking for a writable property? */
GPN_FALLING_BACK = 2 /* Are we doing a recursive call to determine
* if the property is of the other type? */
};
/*
* Shared bits for [property] declarations.
*/
enum PropOpt {
PROP_ALL, PROP_READABLE, PROP_WRITABLE
};
static const char *const propOptNames[] = {
"-all", "-readable", "-writable",
NULL
};
/*
* Forward declarations.
*/
static int Configurable_Getter(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_Setter(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static void DetailsDeleter(void *clientData);
static int DetailsCloner(Tcl_Interp *, void *oldClientData,
void **newClientData);
static void ImplementObjectProperty(Tcl_Object targetObject,
Tcl_Obj *propNamePtr, int installGetter,
int installSetter);
static void ImplementClassProperty(Tcl_Class targetObject,
Tcl_Obj *propNamePtr, int installGetter,
int installSetter);
/*
* Method descriptors
*/
static const Tcl_MethodType GetterType = {
TCL_OO_METHOD_VERSION_1,
"PropertyGetter",
Configurable_Getter,
DetailsDeleter,
DetailsCloner
};
static const Tcl_MethodType SetterType = {
TCL_OO_METHOD_VERSION_1,
"PropertySetter",
Configurable_Setter,
DetailsDeleter,
DetailsCloner
};
/*
* ----------------------------------------------------------------------
*
* TclOO_Configurable_Configure --
*
* Implementation of the oo::configurable->configure method.
*
* ----------------------------------------------------------------------
*/
/*
* Ugly thunks to read and write a property by calling the right method in
* the right way. Note that we MUST be correct in holding references to Tcl_Obj
* values, as this is potentially a call into user code.
*/
static inline int
ReadProperty(
Tcl_Interp *interp,
Object *oPtr,
const char *propName)
{
Tcl_Obj *args[] = {
oPtr->fPtr->myName,
Tcl_ObjPrintf("<ReadProp%s>", propName)
};
int code;
Tcl_IncrRefCount(args[0]);
Tcl_IncrRefCount(args[1]);
code = TclOOPrivateObjectCmd(oPtr, interp, 2, args);
Tcl_DecrRefCount(args[0]);
Tcl_DecrRefCount(args[1]);
switch (code) {
case TCL_BREAK:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property getter for %s did a break", propName));
return TCL_ERROR;
case TCL_CONTINUE:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property getter for %s did a continue", propName));
return TCL_ERROR;
default:
return code;
}
}
static inline int
WriteProperty(
Tcl_Interp *interp,
Object *oPtr,
const char *propName,
Tcl_Obj *valueObj)
{
Tcl_Obj *args[] = {
oPtr->fPtr->myName,
Tcl_ObjPrintf("<WriteProp%s>", propName),
valueObj
};
int code;
Tcl_IncrRefCount(args[0]);
Tcl_IncrRefCount(args[1]);
Tcl_IncrRefCount(args[2]);
code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
Tcl_DecrRefCount(args[0]);
Tcl_DecrRefCount(args[1]);
Tcl_DecrRefCount(args[2]);
switch (code) {
case TCL_BREAK:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property setter for %s did a break", propName));
return TCL_ERROR;
case TCL_CONTINUE:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property setter for %s did a continue", propName));
return TCL_ERROR;
default:
return code;
}
}
/* Look up a property full name. */
static Tcl_Obj *
GetPropertyName(
Tcl_Interp *interp, /* Context and error reporting. */
Object *oPtr, /* Object to get property name from. */
int flags, /* Are we looking for a writable property?
* Can we do a fallback message?
* See GPNFlags for possible values */
Tcl_Obj *namePtr, /* The name supplied by the user. */
GPNCache **cachePtr) /* Where to cache the table, if the caller
* wants that. The contents are to be freed
* with Tcl_Free if the cache is used. */
{
Tcl_Size objc, index, i;
Tcl_Obj *listPtr = TclOOGetAllObjectProperties(
oPtr, flags & GPN_WRITABLE);
Tcl_Obj **objv;
GPNCache *tablePtr;
(void) Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv);
if (cachePtr && *cachePtr) {
tablePtr = *cachePtr;
} else {
tablePtr = (GPNCache *) TclStackAlloc(interp,
offsetof(GPNCache, names) + sizeof(char *) * (objc + 1));
for (i = 0; i < objc; i++) {
tablePtr->names[i] = TclGetString(objv[i]);
}
tablePtr->names[objc] = NULL;
if (cachePtr) {
/*
* Have a cache, but nothing in it so far.
*
* We cache the list here so it doesn't vanish from under our
* feet if a property implementation does something crazy like
* changing the set of properties. The type of copy this does
* means that the copy holds the references to the names in the
* table.
*/
tablePtr->listPtr = TclListObjCopy(NULL, listPtr);
Tcl_IncrRefCount(tablePtr->listPtr);
*cachePtr = tablePtr;
} else {
tablePtr->listPtr = NULL;
}
}
int result = Tcl_GetIndexFromObjStruct(interp, namePtr, tablePtr->names,
sizeof(char *), "property", TCL_INDEX_TEMP_TABLE, &index);
if (result == TCL_ERROR && !(flags & GPN_FALLING_BACK)) {
/*
* If property can be accessed the other way, use a special message.
* We use a recursive call to look this up.
*/
Tcl_InterpState foo = Tcl_SaveInterpState(interp, result);
Tcl_Obj *otherName = GetPropertyName(interp, oPtr,
flags ^ (GPN_WRITABLE | GPN_FALLING_BACK), namePtr, NULL);
result = Tcl_RestoreInterpState(interp, foo);
if (otherName != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property \"%s\" is %s only",
TclGetString(otherName),
(flags & GPN_WRITABLE) ? "read" : "write"));
}
}
if (!cachePtr) {
TclStackFree(interp, tablePtr);
}
if (result != TCL_OK) {
return NULL;
}
return objv[index];
}
/* Release the cache made by GetPropertyName(). */
static inline void
ReleasePropertyNameCache(
Tcl_Interp *interp,
GPNCache **cachePtr)
{
if (*cachePtr) {
GPNCache *tablePtr = *cachePtr;
if (tablePtr->listPtr) {
Tcl_DecrRefCount(tablePtr->listPtr);
}
TclStackFree(interp, tablePtr);
*cachePtr = NULL;
}
}
int
TclOO_Configurable_Configure(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter used for the result, error
* reporting, etc. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
Tcl_Obj *namePtr;
Tcl_Size i, namec;
int code = TCL_OK;
objc -= skip;
if ((objc & 1) && (objc != 1)) {
/*
* Bad (odd > 1) number of arguments.
*/
Tcl_WrongNumArgs(interp, skip, objv, "?-option value ...?");
return TCL_ERROR;
}
objv += skip;
if (objc == 0) {
/*
* Read all properties.
*/
Tcl_Obj *listPtr = TclOOGetAllObjectProperties(oPtr, 0);
Tcl_Obj *resultPtr = Tcl_NewObj(), **namev;
Tcl_IncrRefCount(listPtr);
ListObjGetElements(listPtr, namec, namev);
for (i = 0; i < namec; ) {
code = ReadProperty(interp, oPtr, TclGetString(namev[i]));
if (code != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
break;
}
Tcl_DictObjPut(NULL, resultPtr, namev[i],
Tcl_GetObjResult(interp));
if (++i >= namec) {
Tcl_SetObjResult(interp, resultPtr);
break;
}
Tcl_SetObjResult(interp, Tcl_NewObj());
}
Tcl_DecrRefCount(listPtr);
return code;
} else if (objc == 1) {
/*
* Read a single named property.
*/
namePtr = GetPropertyName(interp, oPtr, 0, objv[0], NULL);
if (namePtr == NULL) {
return TCL_ERROR;
}
return ReadProperty(interp, oPtr, TclGetString(namePtr));
} else if (objc == 2) {
/*
* Special case for writing to one property. Saves fiddling with the
* cache in this common case.
*/
namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[0], NULL);
if (namePtr == NULL) {
return TCL_ERROR;
}
code = WriteProperty(interp, oPtr, TclGetString(namePtr), objv[1]);
if (code == TCL_OK) {
Tcl_ResetResult(interp);
}
return code;
} else {
/*
* Write properties. Slightly tricky because we want to cache the
* table of property names.
*/
GPNCache *cache = NULL;
code = TCL_OK;
for (i = 0; i < objc; i += 2) {
namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[i],
&cache);
if (namePtr == NULL) {
code = TCL_ERROR;
break;
}
code = WriteProperty(interp, oPtr, TclGetString(namePtr),
objv[i + 1]);
if (code != TCL_OK) {
break;
}
}
if (code == TCL_OK) {
Tcl_ResetResult(interp);
}
ReleasePropertyNameCache(interp, &cache);
return code;
}
}
/*
* ----------------------------------------------------------------------
*
* Configurable_Getter, Configurable_Setter --
*
* Standard property implementation. The clientData is a simple Tcl_Obj*
* that contains the name of the property.
*
* ----------------------------------------------------------------------
*/
static int
Configurable_Getter(
void *clientData, /* Which property to read. Actually a Tcl_Obj*
* reference that is the name of the variable
* in the cpntext object. */
Tcl_Interp *interp, /* Interpreter used for the result, error
* reporting, etc. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
Tcl_Var varPtr, aryVar;
Tcl_Obj *valuePtr;
if ((int) Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
objv, NULL);
return TCL_ERROR;
}
varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
propNamePtr, &aryVar);
if (varPtr == NULL) {
return TCL_ERROR;
}
valuePtr = TclPtrGetVar(interp, varPtr, aryVar, propNamePtr, NULL,
TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
static int
Configurable_Setter(
void *clientData, /* Which property to write. Actually a Tcl_Obj*
* reference that is the name of the variable
* in the cpntext object. */
Tcl_Interp *interp, /* Interpreter used for the result, error
* reporting, etc. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
Tcl_Var varPtr, aryVar;
if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
objv, "value");
return TCL_ERROR;
}
varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
propNamePtr, &aryVar);
if (varPtr == NULL) {
return TCL_ERROR;
}
if (TclPtrSetVar(interp, varPtr, aryVar, propNamePtr, NULL,
objv[objc - 1], TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
return TCL_OK;
}
// Simple support functions
static void
DetailsDeleter(
void *clientData)
{
// Just drop the reference count
Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
Tcl_DecrRefCount(propNamePtr);
}
static int
DetailsCloner(
TCL_UNUSED(Tcl_Interp *),
void *oldClientData,
void **newClientData)
{
// Just add another reference to this name; easy!
Tcl_Obj *propNamePtr = (Tcl_Obj *) oldClientData;
Tcl_IncrRefCount(propNamePtr);
*newClientData = propNamePtr;
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ImplementObjectProperty, ImplementClassProperty --
*
* Installs a basic property implementation for a property, either on
* an instance or on a class. It's up to the code that calls these
* to ensure that the property name is syntactically valid.
*
* ----------------------------------------------------------------------
*/
void
ImplementObjectProperty(
Tcl_Object targetObject, /* What to install into. */
Tcl_Obj *propNamePtr, /* Property name. */
int installGetter, /* Whether to install a standard getter. */
int installSetter) /* Whether to install a standard setter. */
{
const char *propName = TclGetString(propNamePtr);
while (propName[0] == '-') {
propName++;
}
if (installGetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<ReadProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewInstanceMethod(
NULL, targetObject, methodName, 0, &GetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
if (installSetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<WriteProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewInstanceMethod(
NULL, targetObject, methodName, 0, &SetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
}
void
ImplementClassProperty(
Tcl_Class targetClass, /* What to install into. */
Tcl_Obj *propNamePtr, /* Property name. */
int installGetter, /* Whether to install a standard getter. */
int installSetter) /* Whether to install a standard setter. */
{
const char *propName = TclGetString(propNamePtr);
while (propName[0] == '-') {
propName++;
}
if (installGetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<ReadProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewMethod(targetClass, methodName, 0, &GetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
if (installSetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<WriteProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewMethod(targetClass, methodName, 0, &SetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
}
/*
* ----------------------------------------------------------------------
*
* FindClassProps --
*
* Discover the properties known to a class and its superclasses.
* The property names become the keys in the accumulator hash table
* (which is used as a set).
*
* ----------------------------------------------------------------------
*/
static void
FindClassProps(
Class *clsPtr, /* The object to inspect. Must exist. */
int writable, /* Whether we're after the readable or writable
* property set. */
Tcl_HashTable *accumulator) /* Where to gather the names. */
{
int i, dummy;
Tcl_Obj *propName;
Class *mixin, *sup;
tailRecurse:
if (writable) {
FOREACH(propName, clsPtr->properties.writable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
} else {
FOREACH(propName, clsPtr->properties.readable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
}
if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
/*
* We do *not* traverse upwards from the root!
*/
return;
}
FOREACH(mixin, clsPtr->mixins) {
FindClassProps(mixin, writable, accumulator);
}
if (clsPtr->superclasses.num == 1) {
clsPtr = clsPtr->superclasses.list[0];
goto tailRecurse;
}
FOREACH(sup, clsPtr->superclasses) {
FindClassProps(sup, writable, accumulator);
}
}
/*
* ----------------------------------------------------------------------
*
* FindObjectProps --
*
* Discover the properties known to an object and all its classes.
* The property names become the keys in the accumulator hash table
* (which is used as a set).
*
* ----------------------------------------------------------------------
*/
static void
FindObjectProps(
Object *oPtr, /* The object to inspect. Must exist. */
int writable, /* Whether we're after the readable or writable
* property set. */
Tcl_HashTable *accumulator) /* Where to gather the names. */
{
int i, dummy;
Tcl_Obj *propName;
Class *mixin;
if (writable) {
FOREACH(propName, oPtr->properties.writable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
} else {
FOREACH(propName, oPtr->properties.readable) {
Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
}
}
FOREACH(mixin, oPtr->mixins) {
FindClassProps(mixin, writable, accumulator);
}
FindClassProps(oPtr->selfCls, writable, accumulator);
}
/*
* ----------------------------------------------------------------------
*
* GetAllClassProperties --
*
* Get the list of all properties known to a class, including to its
* superclasses. Manages a cache so this operation is usually cheap.
* The order of properties in the resulting list is undefined.
*
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
GetAllClassProperties(
Class *clsPtr, /* The class to inspect. Must exist. */
int writable, /* Whether to get writable properties. If
* false, readable properties will be returned
* instead. */
int *allocated) /* Address of variable to set to true if a
* Tcl_Obj was allocated and may be safely
* modified by the caller. */
{
Tcl_HashTable hashTable;
FOREACH_HASH_DECLS;
Tcl_Obj *propName, *result;
/*
* Look in the cache.
*/
if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
if (writable) {
if (clsPtr->properties.allWritableCache) {
*allocated = 0;
return clsPtr->properties.allWritableCache;
}
} else {
if (clsPtr->properties.allReadableCache) {
*allocated = 0;
return clsPtr->properties.allReadableCache;
}
}
}
/*
* Gather the information. Unsorted! (Caller will sort.)
*/
*allocated = 1;
Tcl_InitObjHashTable(&hashTable);
FindClassProps(clsPtr, writable, &hashTable);
TclNewObj(result);
FOREACH_HASH_KEY(propName, &hashTable) {
Tcl_ListObjAppendElement(NULL, result, propName);
}
Tcl_DeleteHashTable(&hashTable);
/*
* Cache the information. Also purges the cache.
*/
if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
if (clsPtr->properties.allWritableCache) {
Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
clsPtr->properties.allWritableCache = NULL;
}
if (clsPtr->properties.allReadableCache) {
Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
clsPtr->properties.allReadableCache = NULL;
}
}
clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
if (writable) {
clsPtr->properties.allWritableCache = result;
} else {
clsPtr->properties.allReadableCache = result;
}
Tcl_IncrRefCount(result);
return result;
}
/*
* ----------------------------------------------------------------------
*
* SortPropList --
* Sort a list of names of properties. Simple support function. Assumes
* that the list Tcl_Obj is unshared and doesn't have a string
* representation.
*
* ----------------------------------------------------------------------
*/
static int
PropNameCompare(
const void *a,
const void *b)
{
Tcl_Obj *first = *(Tcl_Obj **) a;
Tcl_Obj *second = *(Tcl_Obj **) b;
return TclStringCmp(first, second, 0, 0, TCL_INDEX_NONE);
}
static inline void
SortPropList(
Tcl_Obj *list)
{
Tcl_Size ec;
Tcl_Obj **ev;
if (Tcl_IsShared(list)) {
Tcl_Panic("shared property list cannot be sorted");
}
Tcl_ListObjGetElements(NULL, list, &ec, &ev);
TclInvalidateStringRep(list);
qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetAllObjectProperties --
*
* Get the sorted list of all properties known to an object, including to
* its classes. Manages a cache so this operation is usually cheap.
*
* ----------------------------------------------------------------------
*/
Tcl_Obj *
TclOOGetAllObjectProperties(
Object *oPtr, /* The object to inspect. Must exist. */
int writable) /* Whether to get writable properties. If
* false, readable properties will be returned
* instead. */
{
Tcl_HashTable hashTable;
FOREACH_HASH_DECLS;
Tcl_Obj *propName, *result;
/*
* Look in the cache.
*/
if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
if (writable) {
if (oPtr->properties.allWritableCache) {
return oPtr->properties.allWritableCache;
}
} else {
if (oPtr->properties.allReadableCache) {
return oPtr->properties.allReadableCache;
}
}
}
/*
* Gather the information. Unsorted! (Caller will sort.)
*/
Tcl_InitObjHashTable(&hashTable);
FindObjectProps(oPtr, writable, &hashTable);
TclNewObj(result);
FOREACH_HASH_KEY(propName, &hashTable) {
Tcl_ListObjAppendElement(NULL, result, propName);
}
Tcl_DeleteHashTable(&hashTable);
SortPropList(result);
/*
* Cache the information.
*/
if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
if (oPtr->properties.allWritableCache) {
Tcl_DecrRefCount(oPtr->properties.allWritableCache);
oPtr->properties.allWritableCache = NULL;
}
if (oPtr->properties.allReadableCache) {
Tcl_DecrRefCount(oPtr->properties.allReadableCache);
oPtr->properties.allReadableCache = NULL;
}
}
oPtr->properties.epoch = oPtr->fPtr->epoch;
if (writable) {
oPtr->properties.allWritableCache = result;
} else {
oPtr->properties.allReadableCache = result;
}
Tcl_IncrRefCount(result);
return result;
}
/*
* ----------------------------------------------------------------------
*
* SetPropertyList --
*
* Helper for writing a property list (which is actually a set).
*
* ----------------------------------------------------------------------
*/
static inline void
SetPropertyList(
PropertyList *propList, /* The property list to write. Replaces the
* property list's contents. */
Tcl_Size objc, /* Number of property names. */
Tcl_Obj *const objv[]) /* Property names. */
{
Tcl_Size i, n;
Tcl_Obj *propObj;
int created;
Tcl_HashTable uniqueTable;
for (i=0 ; i<objc ; i++) {
Tcl_IncrRefCount(objv[i]);
}
FOREACH(propObj, *propList) {
Tcl_DecrRefCount(propObj);
}
if (i != objc) {
if (objc == 0) {
Tcl_Free(propList->list);
} else if (i) {
propList->list = (Tcl_Obj **)
Tcl_Realloc(propList->list, sizeof(Tcl_Obj *) * objc);
} else {
propList->list = (Tcl_Obj **)
Tcl_Alloc(sizeof(Tcl_Obj *) * objc);
}
}
propList->num = 0;
if (objc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<objc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
if (created) {
propList->list[n++] = objv[i];
} else {
Tcl_DecrRefCount(objv[i]);
}
}
propList->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != objc) {
propList->list = (Tcl_Obj **)
Tcl_Realloc(propList->list, sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
/*
* ----------------------------------------------------------------------
*
* TclOOInstallReadableProperties --
*
* Helper for writing the readable property list (which is actually a set)
* that includes flushing the name cache.
*
* ----------------------------------------------------------------------
*/
void
TclOOInstallReadableProperties(
PropertyStorage *props, /* Which property list to install into. */
Tcl_Size objc, /* Number of property names. */
Tcl_Obj *const objv[]) /* Property names. */
{
if (props->allReadableCache) {
Tcl_DecrRefCount(props->allReadableCache);
props->allReadableCache = NULL;
}
SetPropertyList(&props->readable, objc, objv);
}
/*
* ----------------------------------------------------------------------
*
* TclOOInstallWritableProperties --
*
* Helper for writing the writable property list (which is actually a set)
* that includes flushing the name cache.
*
* ----------------------------------------------------------------------
*/
void
TclOOInstallWritableProperties(
PropertyStorage *props, /* Which property list to install into. */
Tcl_Size objc, /* Number of property names. */
Tcl_Obj *const objv[]) /* Property names. */
{
if (props->allWritableCache) {
Tcl_DecrRefCount(props->allWritableCache);
props->allWritableCache = NULL;
}
SetPropertyList(&props->writable, objc, objv);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetPropertyList --
*
* Helper for reading a property list.
*
* ----------------------------------------------------------------------
*/
Tcl_Obj *
TclOOGetPropertyList(
PropertyList *propList) /* The property list to read. */
{
Tcl_Obj *resultObj, *propNameObj;
Tcl_Size i;
TclNewObj(resultObj);
FOREACH(propNameObj, *propList) {
Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
}
return resultObj;
}
/*
* ----------------------------------------------------------------------
*
* TclOOInstallStdPropertyImpls --
*
* Validates a (dashless) property name, and installs implementation
* methods if asked to do so (readable and writable flags).
*
* ----------------------------------------------------------------------
*/
int
TclOOInstallStdPropertyImpls(
void *useInstance,
Tcl_Interp *interp,
Tcl_Obj *propName,
int readable,
int writable)
{
const char *name, *reason;
Tcl_Size len;
char flag = TCL_DONT_QUOTE_HASH;
/*
* Validate the property name. Note that just calling TclScanElement() is
* cheaper than actually formatting a list and comparing the string
* version of that with the original, as TclScanElement() is one of the
* core parts of doing that; this skips a whole load of irrelevant memory
* allocations!
*/
name = Tcl_GetStringFromObj(propName, &len);
if (Tcl_StringMatch(name, "-*")) {
reason = "must not begin with -";
goto badProp;
}
if (TclScanElement(name, len, &flag) != len) {
reason = "must be a simple word";
goto badProp;
}
if (Tcl_StringMatch(name, "*::*")) {
reason = "must not contain namespace separators";
goto badProp;
}
if (Tcl_StringMatch(name, "*[()]*")) {
reason = "must not contain parentheses";
goto badProp;
}
/*
* Install the implementations... if asked to do so.
*/
if (useInstance) {
Tcl_Object object = TclOOGetDefineCmdContext(interp);
if (!object) {
return TCL_ERROR;
}
ImplementObjectProperty(object, propName, readable, writable);
} else {
Tcl_Class cls = (Tcl_Class) TclOOGetClassDefineCmdContext(interp);
if (!cls) {
return TCL_ERROR;
}
ImplementClassProperty(cls, propName, readable, writable);
}
return TCL_OK;
badProp:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad property name \"%s\": %s", name, reason));
OO_ERROR(interp, PROPERTY_FORMAT);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* TclOODefinePropertyCmd --
*
* Implementation of the "property" definition for classes and instances
* governed by the [oo::configurable] metaclass.
*
* ----------------------------------------------------------------------
*/
int
TclOODefinePropertyCmd(
void *useInstance, /* NULL for class, non-NULL for object. */
Tcl_Interp *interp, /* For error reporting and lookup. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int i;
const char *const options[] = {
"-get", "-kind", "-set", NULL
};
enum Options {
OPT_GET, OPT_KIND, OPT_SET
};
const char *const kinds[] = {
"readable", "readwrite", "writable", NULL
};
enum Kinds {
KIND_RO, KIND_RW, KIND_WO
};
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!useInstance && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
OO_ERROR(interp, MONKEY_BUSINESS);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
Tcl_Obj *propObj = objv[i], *nextObj, *argObj, *hyphenated;
Tcl_Obj *getterScript = NULL, *setterScript = NULL;
/*
* Parse the extra options for the property.
*/
int kind = KIND_RW;
while (i + 1 < objc) {
int option;
nextObj = objv[i + 1];
if (TclGetString(nextObj)[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, nextObj, options, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
if (i + 2 >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing %s to go with %s option",
(option == OPT_KIND ? "kind value" : "body"),
options[option]));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
argObj = objv[i + 2];
i += 2;
switch (option) {
case OPT_GET:
getterScript = argObj;
break;
case OPT_SET:
setterScript = argObj;
break;
case OPT_KIND:
if (Tcl_GetIndexFromObj(interp, argObj, kinds, "kind", 0,
&kind) != TCL_OK) {
return TCL_ERROR;
}
break;
}
}
/*
* Install the property. Note that TclOOInstallStdPropertyImpls
* validates the property name as well.
*/
if (TclOOInstallStdPropertyImpls(useInstance, interp, propObj,
kind != KIND_WO && getterScript == NULL,
kind != KIND_RO && setterScript == NULL) != TCL_OK) {
return TCL_ERROR;
}
hyphenated = Tcl_ObjPrintf("-%s", TclGetString(propObj));
if (useInstance) {
TclOORegisterInstanceProperty(oPtr, hyphenated,
kind != KIND_WO, kind != KIND_RO);
} else {
TclOORegisterProperty(oPtr->classPtr, hyphenated,
kind != KIND_WO, kind != KIND_RO);
}
Tcl_BounceRefCount(hyphenated);
/*
* Create property implementation methods by using the right
* back-end API, but only if the user has given us the bodies of the
* methods we'll make.
*/
if (getterScript != NULL) {
Tcl_Obj *getterName = Tcl_ObjPrintf("<ReadProp-%s>",
TclGetString(propObj));
Tcl_Obj *argsPtr = Tcl_NewObj();
Method *mPtr;
Tcl_IncrRefCount(getterScript);
if (useInstance) {
mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
getterName, argsPtr, getterScript, NULL);
} else {
mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
getterName, argsPtr, getterScript, NULL);
}
Tcl_BounceRefCount(getterName);
Tcl_BounceRefCount(argsPtr);
Tcl_DecrRefCount(getterScript);
if (mPtr == NULL) {
return TCL_ERROR;
}
}
if (setterScript != NULL) {
Tcl_Obj *setterName = Tcl_ObjPrintf("<WriteProp-%s>",
TclGetString(propObj));
Tcl_Obj *argsPtr;
Method *mPtr;
TclNewLiteralStringObj(argsPtr, "value");
Tcl_IncrRefCount(setterScript);
if (useInstance) {
mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
setterName, argsPtr, setterScript, NULL);
} else {
mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
setterName, argsPtr, setterScript, NULL);
}
Tcl_BounceRefCount(setterName);
Tcl_BounceRefCount(argsPtr);
Tcl_DecrRefCount(setterScript);
if (mPtr == NULL) {
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOInfoClassPropCmd, TclOOInfoObjectPropCmd --
*
* Implements [info class properties $clsName ?$option...?] and
* [info object properties $objName ?$option...?]
*
* ----------------------------------------------------------------------
*/
int
TclOOInfoClassPropCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
int i, idx, all = 0, writable = 0, allocated = 0;
Tcl_Obj *result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
&idx) != TCL_OK) {
return TCL_ERROR;
}
switch (idx) {
case PROP_ALL:
all = 1;
break;
case PROP_READABLE:
writable = 0;
break;
case PROP_WRITABLE:
writable = 1;
break;
}
}
/*
* Get the properties.
*/
if (all) {
result = GetAllClassProperties(clsPtr, writable, &allocated);
if (allocated) {
SortPropList(result);
}
} else {
if (writable) {
result = TclOOGetPropertyList(&clsPtr->properties.writable);
} else {
result = TclOOGetPropertyList(&clsPtr->properties.readable);
}
SortPropList(result);
}
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
int
TclOOInfoObjectPropCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
int i, idx, all = 0, writable = 0;
Tcl_Obj *result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
&idx) != TCL_OK) {
return TCL_ERROR;
}
switch (idx) {
case PROP_ALL:
all = 1;
break;
case PROP_READABLE:
writable = 0;
break;
case PROP_WRITABLE:
writable = 1;
break;
}
}
/*
* Get the properties.
*/
if (all) {
result = TclOOGetAllObjectProperties(oPtr, writable);
} else {
if (writable) {
result = TclOOGetPropertyList(&oPtr->properties.writable);
} else {
result = TclOOGetPropertyList(&oPtr->properties.readable);
}
SortPropList(result);
}
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOReleasePropertyStorage --
*
* Delete the memory associated with a class or object's properties.
*
* ----------------------------------------------------------------------
*/
static inline void
ReleasePropertyList(
PropertyList *propList)
{
Tcl_Obj *propertyObj;
Tcl_Size i;
FOREACH(propertyObj, *propList) {
Tcl_DecrRefCount(propertyObj);
}
Tcl_Free(propList->list);
propList->list = NULL;
propList->num = 0;
}
void
TclOOReleasePropertyStorage(
PropertyStorage *propsPtr)
{
if (propsPtr->allReadableCache) {
Tcl_DecrRefCount(propsPtr->allReadableCache);
}
if (propsPtr->allWritableCache) {
Tcl_DecrRefCount(propsPtr->allWritableCache);
}
if (propsPtr->readable.num) {
ReleasePropertyList(&propsPtr->readable);
}
if (propsPtr->writable.num) {
ReleasePropertyList(&propsPtr->writable);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclOOScript.h.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
"\t\t\tforeach link $args {\n"
"\t\t\t\tif {[llength $link] == 2} {\n"
"\t\t\t\t\tlassign $link src dst\n"
"\t\t\t\t} elseif {[llength $link] == 1} {\n"
"\t\t\t\t\tlassign $link src\n"
"\t\t\t\t\tset dst $src\n"
"\t\t\t\t} else {\n"
| | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
"\t\t\tforeach link $args {\n"
"\t\t\t\tif {[llength $link] == 2} {\n"
"\t\t\t\t\tlassign $link src dst\n"
"\t\t\t\t} elseif {[llength $link] == 1} {\n"
"\t\t\t\t\tlassign $link src\n"
"\t\t\t\t\tset dst $src\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {![string match ::* $src]} {\n"
"\t\t\t\t\tset src [string cat $ns :: $src]\n"
"\t\t\t\t}\n"
"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
"\t\t::namespace export -clear\n"
"\t\t::rename tmp::initialise initialize\n"
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get -unexport {} {\n"
| | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 |
"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
"\t\t::namespace export -clear\n"
"\t\t::rename tmp::initialise initialize\n"
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get -unexport {} {\n"
"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set -unexport list {\n"
"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Resolve -unexport list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
"\t\tmethod -set -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
"\t\tvariable object\n"
"\t\tunexport create createWithNamespace\n"
"\t\tmethod new args {\n"
"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\t\tset object [next {*}$args]\n"
"\t\t\t\t::oo::objdefine $object {\n"
"\t\t\t\t\tmethod destroy {} {\n"
| | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | 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 |
"\t\tvariable object\n"
"\t\tunexport create createWithNamespace\n"
"\t\tmethod new args {\n"
"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\t\tset object [next {*}$args]\n"
"\t\t\t\t::oo::objdefine $object {\n"
"\t\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $object\n"
"\t\t}\n"
"\t}\n"
"\tclass create abstract {\n"
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
"\tnamespace eval configuresupport {\n"
"\t\t::namespace eval configurableclass {\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::define\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\t::namespace eval configurableobject {\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::objdefine\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\t::oo::define configurable {\n"
"\t\t\tdefinitionnamespace -instance configurableobject\n"
"\t\t\tdefinitionnamespace -class configurableclass\n"
"\t\t}\n"
"\t}\n"
"\tclass create configurable {\n"
"\t\tsuperclass class\n"
"\t\tconstructor {{definitionScript \"\"}} {\n"
|
| ︙ | ︙ |
Changes to generic/tclOOStubInit.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
TclOONewProcInstanceMethodEx, /* 9 */
TclOONewProcMethodEx, /* 10 */
TclOOInvokeObject, /* 11 */
TclOOObjectSetFilters, /* 12 */
TclOOClassSetFilters, /* 13 */
TclOOObjectSetMixins, /* 14 */
TclOOClassSetMixins, /* 15 */
};
static const TclOOStubHooks tclOOStubHooks = {
&tclOOIntStubs
};
const TclOOStubs tclOOStubs = {
| > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
TclOONewProcInstanceMethodEx, /* 9 */
TclOONewProcMethodEx, /* 10 */
TclOOInvokeObject, /* 11 */
TclOOObjectSetFilters, /* 12 */
TclOOClassSetFilters, /* 13 */
TclOOObjectSetMixins, /* 14 */
TclOOClassSetMixins, /* 15 */
TclOOMakeProcInstanceMethod2, /* 16 */
TclOOMakeProcMethod2, /* 17 */
};
static const TclOOStubHooks tclOOStubHooks = {
&tclOOIntStubs
};
const TclOOStubs tclOOStubs = {
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 |
*
* Notice that different structures with the same name appear in other files.
* The structure defined below is used in this file only.
*/
typedef struct {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
| | | | | | | | | | | | | | 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 |
*
* Notice that different structures with the same name appear in other files.
* The structure defined below is used in this file only.
*/
typedef struct {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
* TclSubstTokens() from a literal text
* where bs+nl sequences occurred in it, if
* any. I.e. this table keeps track of
* invisible and stripped continuation lines.
* Its keys are Tcl_Obj pointers, the values
* are ContLineLoc pointers. See the file
* tclCompile.h for the definition of this
* structure, and for references to all
* related places in the core. */
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
* that a Tcl_Obj was not allocated by some
* other thread. */
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static void TclThreadFinalizeContLines(void *clientData);
static ThreadSpecificData *TclGetContLineTable(void);
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
/*
* Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
*/
#define PACK_BIGNUM(bignum, objPtr) \
if ((bignum).used > 0x7FFF) { \
| | | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
/*
* Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
*/
#define PACK_BIGNUM(bignum, objPtr) \
if ((bignum).used > 0x7FFF) { \
mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \
*temp = bignum; \
(objPtr)->internalRep.twoPtrValue.ptr1 = temp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \
} else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \
(objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
/*
* Prototypes for functions defined later in this file:
*/
static int ParseBoolean(Tcl_Obj *objPtr);
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 |
/*
* The structure below defines the Tcl obj hash key type.
*/
const Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
| | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
/*
* The structure below defines the Tcl obj hash key type.
*/
const Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
TCL_HASH_KEY_DIRECT_COMPARE,/* allows compare keys by pointers */
TclHashObjKey, /* hashKeyProc */
TclCompareObjKeys, /* compareKeysProc */
AllocObjEntry, /* allocEntryProc */
TclFreeObjEntry /* freeEntryProc */
};
/*
|
| ︙ | ︙ | |||
345 346 347 348 349 350 351 |
* On 32-bit systems, the ref counts do not cross 0x7fffffff. On 64-bit
* implementations, ref counts will never reach this value (unless explicitly
* incremented without actual references!)
*/
#define FREEDREFCOUNTFILLER \
(Tcl_Size)(sizeof(objPtr->refCount) == 4 ? 0xe8e8e8e8 : 0xe8e8e8e8e8e8e8e8)
#endif
| < | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
* On 32-bit systems, the ref counts do not cross 0x7fffffff. On 64-bit
* implementations, ref counts will never reach this value (unless explicitly
* incremented without actual references!)
*/
#define FREEDREFCOUNTFILLER \
(Tcl_Size)(sizeof(objPtr->refCount) == 4 ? 0xe8e8e8e8 : 0xe8e8e8e8e8e8e8e8)
#endif
/*
*-------------------------------------------------------------------------
*
* TclInitObjectSubsystem --
*
* This function is invoked to perform once-only initialization of the
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
TclInitObjSubsystem(void)
{
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
| | | | | | | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
TclInitObjSubsystem(void)
{
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclProcBodyType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclStringType);
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
tclObjsFreed = 0;
{
int i;
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
| | | 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
(void)TclGetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
* Then compute the table slice covering the range of the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 |
void
TclContinuationsCopy(
Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
| | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
void
TclContinuationsCopy(
Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
}
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 |
ContLineLoc *
TclContinuationsGet(
Tcl_Obj *objPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
| | | | 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
ContLineLoc *
TclContinuationsGet(
Tcl_Obj *objPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (!hPtr) {
return NULL;
}
return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
854 855 856 857 858 859 860 |
Tcl_HashSearch search;
Tcl_Size numElems;
/*
* Get the test for a valid list out of the way first.
*/
| | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
Tcl_HashSearch search;
Tcl_Size numElems;
/*
* Get the test for a valid list out of the way first.
*/
if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
/*
* Type names are NUL-terminated, not counted strings. This code relies on
* that.
*/
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 |
* representation.
*/
if (typePtr->setFromAnyProc == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't convert value to type %s", typePtr->name));
| | | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 |
* representation.
*/
if (typePtr->setFromAnyProc == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't convert value to type %s", typePtr->name));
Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", (char *)NULL);
}
return TCL_ERROR;
}
return typePtr->setFromAnyProc(interp, objPtr);
}
|
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
* already killed the thread-global data structures. Performing
* TCL_TSD_INIT will leave us with an uninitialized memory block upon
* which we crash (if we where to access the uninitialized hashtable).
*/
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | | 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 |
* already killed the thread-global data structures. Performing
* TCL_TSD_INIT will leave us with an uninitialized memory block upon
* which we crash (if we where to access the uninitialized hashtable).
*/
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
|
| ︙ | ︙ | |||
1467 1468 1469 1470 1471 1472 1473 |
* already killed the thread-global data structures. Performing
* TCL_TSD_INIT will leave us with an uninitialized memory block upon
* which we crash (if we where to access the uninitialized hashtable).
*/
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 |
* already killed the thread-global data structures. Performing
* TCL_TSD_INIT will leave us with an uninitialized memory block upon
* which we crash (if we where to access the uninitialized hashtable).
*/
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
|
| ︙ | ︙ | |||
1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED)
char *
TclGetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
void *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
| > | 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED)
#undef TclGetStringFromObj
char *
TclGetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
void *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
|
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 |
Tcl_GetBoolFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
int flags,
char *charPtr) /* Place to store resulting boolean. */
{
int result;
if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) {
result = -1;
goto boolEnd;
} else if (objPtr == NULL) {
if (interp) {
TclNewObj(objPtr);
TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0);
Tcl_DecrRefCount(objPtr);
}
return TCL_ERROR;
}
do {
| > | | | > > > > > > > > > > > > > > > > | 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 |
Tcl_GetBoolFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
int flags,
char *charPtr) /* Place to store resulting boolean. */
{
int result;
Tcl_Size length;
if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) {
result = -1;
goto boolEnd;
} else if (objPtr == NULL) {
if (interp) {
TclNewObj(objPtr);
TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0);
Tcl_DecrRefCount(objPtr);
}
return TCL_ERROR;
}
do {
if (TclHasInternalRep(objPtr, &tclIntType) || TclHasInternalRep(objPtr, &tclBooleanType)) {
result = (objPtr->internalRep.wideValue != 0);
goto boolEnd;
}
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
/*
* Caution: Don't be tempted to check directly for the "double"
* Tcl_ObjType and then compare the internalrep to 0.0. This isn't
* reliable because a "double" Tcl_ObjType can hold the NaN value.
* Use the API Tcl_GetDoubleFromObj, which does the checking and
* sets the proper error message for us.
*/
double d;
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
}
result = (d != 0.0);
goto boolEnd;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
result = 1;
boolEnd:
if (charPtr != NULL) {
flags &= (TCL_NULL_OK-2);
if (flags) {
if (flags == (int)sizeof(int)) {
*(int *)charPtr = result;
return TCL_OK;
} else if (flags == (int)sizeof(short)) {
*(short *)charPtr = result;
return TCL_OK;
} else {
Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj");
}
}
*charPtr = result;
}
return TCL_OK;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("expected boolean value%s but got a list",
(flags & TCL_NULL_OK) ? " or \"\"" : ""));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0)));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2105 2106 2107 2108 2109 2110 2111 |
/*
* For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
* whether a boolean conversion is possible without generating the string
* rep.
*/
if (objPtr->bytes == NULL) {
| | | | | | 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 |
/*
* For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
* whether a boolean conversion is possible without generating the string
* rep.
*/
if (objPtr->bytes == NULL) {
if (TclHasInternalRep(objPtr, &tclIntType)) {
if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
return TCL_OK;
}
goto badBoolean;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
goto badBoolean;
}
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
goto badBoolean;
}
}
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
badBoolean:
if (interp != NULL) {
Tcl_Size length;
const char *str = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
Tcl_AppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (char *)NULL);
}
return TCL_ERROR;
}
static int
ParseBoolean(
Tcl_Obj *objPtr) /* The object to parse/convert. */
|
| ︙ | ︙ | |||
2417 2418 2419 2420 2421 2422 2423 2424 |
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
do {
| > | | | | | > > > > > > > > > > > > > > > > | 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
Tcl_Size length;
do {
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
if (isnan(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
(char *)NULL);
}
return TCL_ERROR;
}
*dblPtr = (double) objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclIntType)) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
mp_int big;
TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("expected floating-point number but got a list", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2555 2556 2557 2558 2559 2560 2561 |
return TCL_ERROR;
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
if (interp != NULL) {
const char *s =
"integer value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
| | < | 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 |
return TCL_ERROR;
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
if (interp != NULL) {
const char *s =
"integer value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
}
return TCL_ERROR;
}
*intPtr = (int) l;
return TCL_OK;
#endif
}
/*
*----------------------------------------------------------------------
*
* SetIntFromAny --
*
* Attempts to force the internal representation for a Tcl object to
|
| ︙ | ︙ | |||
2647 2648 2649 2650 2651 2652 2653 2654 2655 |
int
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
do {
#ifdef TCL_WIDE_INT_IS_LONG
| > | | | | | | | | | 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 |
int
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
Tcl_Size length;
do {
#ifdef TCL_WIDE_INT_IS_LONG
if (TclHasInternalRep(objPtr, &tclIntType)) {
*longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
#else
if (TclHasInternalRep(objPtr, &tclIntType)) {
/*
* We return any integer in the range LONG_MIN to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
* existing semantics for conversion of integers on input, but
* avoids inadvertent demotion of wide integers to 32-bit ones in
* the internal rep.
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
if (w >= (Tcl_WideInt)(LONG_MIN)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = (long)w;
return TCL_OK;
}
goto tooLarge;
}
#endif
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
* long range get auto-narrowed to tclIntType, while all the
* values in the unsigned long range will fit in a long.
*/
|
| ︙ | ︙ | |||
2722 2723 2724 2725 2726 2727 2728 |
tooLarge:
#endif
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
| | > > > > > > > > > > > > > > > | 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 |
tooLarge:
#endif
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
}
return TCL_ERROR;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("expected integer but got a list", -1));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 |
TclNewObj(objPtr);
TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewWideIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewWideIntObj to create new wide integer end up calling the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 |
TclNewObj(objPtr);
TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_NewWideUIntObj --
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_NewWideUIntObj(
Tcl_WideUInt uwideValue)
/* Wide integer used to initialize the new
* object. */
{
Tcl_Obj *objPtr;
TclNewUIntObj(objPtr, uwideValue);
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewWideIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewWideIntObj to create new wide integer end up calling the
|
| ︙ | ︙ | |||
2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 |
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
TclSetIntObj(objPtr, wideValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetWideIntFromObj --
*
* Attempt to return a wide integer from the Tcl object "objPtr". If the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2956 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 |
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
TclSetIntObj(objPtr, wideValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetWideUIntObj --
*
* Modify an object to be a wide integer object or a bignum object
* and to have the specified unsigned wide integer value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetWideUIntObj(
Tcl_Obj *objPtr, /* Object w. internal rep to init. */
Tcl_WideUInt uwideValue)
/* Wide integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetWideUIntObj");
}
if (uwideValue > WIDE_MAX) {
mp_int bignumValue;
if (mp_init_u64(&bignumValue, uwideValue) != MP_OKAY) {
Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj");
}
TclSetBignumInternalRep(objPtr, &bignumValue);
} {
TclSetIntObj(objPtr, (Tcl_WideInt)uwideValue);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetWideIntFromObj --
*
* Attempt to return a wide integer from the Tcl object "objPtr". If the
|
| ︙ | ︙ | |||
2909 2910 2911 2912 2913 2914 2915 2916 |
int
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
do {
| > | | | | | | | | 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 |
int
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
Tcl_Size length;
do {
if (TclHasInternalRep(objPtr, &tclIntType)) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
*/
mp_int big;
Tcl_WideUInt value = 0;
|
| ︙ | ︙ | |||
2957 2958 2959 2960 2961 2962 2963 |
}
}
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
| | > > > > > > > > > > > > > > > | 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 |
}
}
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
}
return TCL_ERROR;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("expected integer but got a list", -1));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
2995 2996 2997 2998 2999 3000 3001 |
Tcl_GetWideUIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideUInt *wideUIntPtr)
/* Place to store resulting long. */
{
do {
| | | | | | 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 |
Tcl_GetWideUIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideUInt *wideUIntPtr)
/* Place to store resulting long. */
{
do {
if (TclHasInternalRep(objPtr, &tclIntType)) {
if (objPtr->internalRep.wideValue < 0) {
wideUIntOutOfRange:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected unsigned integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
*wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
goto wideUIntOutOfRange;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideUInt, even when auto-narrowing is enabled.
*/
mp_int big;
Tcl_WideUInt value = 0;
|
| ︙ | ︙ | |||
3041 3042 3043 3044 3045 3046 3047 |
}
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
| | | 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 |
}
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
}
return TCL_ERROR;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3079 3080 3081 3082 3083 3084 3085 |
int
TclGetWideBitsFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
{
do {
| | | | | | | | | 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 |
int
TclGetWideBitsFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
{
do {
if (TclHasInternalRep(objPtr, &tclIntType)) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
mp_int big;
mp_err err;
Tcl_WideUInt value = 0, scratch;
size_t numBytes;
unsigned char *bytes = (unsigned char *) &scratch;
|
| ︙ | ︙ | |||
3375 3376 3377 3378 3379 3380 3381 |
GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
int copy, /* Whether to copy the returned bignum value */
mp_int *bignumValue) /* Returned bignum value. */
{
do {
| | | 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 |
GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
int copy, /* Whether to copy the returned bignum value */
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (TclHasInternalRep(objPtr, &tclBignumType)) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3400 3401 3402 3403 3404 3405 3406 |
*/
if (objPtr->bytes == NULL) {
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
| | | | | | | | 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 |
*/
if (objPtr->bytes == NULL) {
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclIntType)) {
if (mp_init_i64(bignumValue,
objPtr->internalRep.wideValue) != MP_OKAY) {
return TCL_ERROR;
}
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3609 3610 3611 3612 3613 3614 3615 3616 |
int
Tcl_GetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
void **clientDataPtr,
int *typePtr)
{
do {
| > | | | > > > > > > > > > > > > > > > | 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 |
int
Tcl_GetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
void **clientDataPtr,
int *typePtr)
{
Tcl_Size length;
do {
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
if (isnan(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclIntType)) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, &tclBignumType)) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
sizeof(mp_int));
TclUnpackBignum(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("expected number but got a list", -1));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while (TCL_OK ==
TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
return TCL_ERROR;
}
int
|
| ︙ | ︙ | |||
3664 3665 3666 3667 3668 3669 3670 |
if (numBytes < 0) {
numBytes = strlen(bytes);
}
if (numBytes > INT_MAX) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%d bytes) exceeded", INT_MAX));
| | | 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 |
if (numBytes < 0) {
numBytes = strlen(bytes);
}
if (numBytes > INT_MAX) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%d bytes) exceeded", INT_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return TCL_ERROR;
}
objPtr->bytes = (char *) bytes;
objPtr->length = numBytes;
|
| ︙ | ︙ | |||
3817 3818 3819 3820 3821 3822 3823 |
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
| | | 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 |
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"incr ref count");
}
}
# endif /* TCL_THREADS */
++(objPtr)->refCount;
}
#else /* !TCL_MEM_DEBUG */
void
|
| ︙ | ︙ | |||
3890 3891 3892 3893 3894 3895 3896 |
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
| | | 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 |
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"decr ref count");
}
}
# endif /* TCL_THREADS */
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
|
| ︙ | ︙ | |||
3972 3973 3974 3975 3976 3977 3978 |
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
| | | 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 |
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"check shared status");
}
}
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
|
| ︙ | ︙ | |||
4083 4084 4085 4086 4087 4088 4089 |
const char *p1, *p2;
size_t l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
| | > > | 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 |
const char *p1, *p2;
size_t l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
if (objPtr1 == objPtr2) {
return 1;
}
*/
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
* in a register.
*/
|
| ︙ | ︙ | |||
4262 4263 4264 4265 4266 4267 4268 |
* is not deleted.
*
* If any check fails, then force another conversion to the command type,
* to discard the old rep and create a new one.
*/
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
| | | | | | | | | | | | | | | | | 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 |
* is not deleted.
*
* If any check fails, then force another conversion to the command type,
* to discard the old rep and create a new one.
*/
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if (TclHasInternalRep(objPtr, &tclCmdNameType)) {
Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
TclGetCurrentNamespace(interp);
if ((resPtr->refNsPtr == NULL)
|| ((refNsPtr == resPtr->refNsPtr)
&& (resPtr->refNsId == refNsPtr->nsId)
&& (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
return (Tcl_Command) cmdPtr;
}
}
}
/*
* OK, must create a new internal representation (or fail) as any cache we
* had is invalid one way or another.
*/
/* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4377 4378 4379 4380 4381 4382 4383 |
Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
* CmdName object. */
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
ResolvedCmdName *resPtr;
| | | 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 |
Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
* CmdName object. */
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
ResolvedCmdName *resPtr;
if (TclHasInternalRep(objPtr, &tclCmdNameType)) {
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
return;
}
}
SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
|
| ︙ | ︙ | |||
4524 4525 4526 4527 4528 4529 4530 |
*/
if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
return TCL_ERROR;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
| | | 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 |
*/
if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
return TCL_ERROR;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if (TclHasInternalRep(objPtr, &tclCmdNameType) && (resPtr->refCount == 1)) {
/*
* Re-use existing ResolvedCmdName struct when possible.
* Cleanup the old fields that need it.
*/
Command *oldCmdPtr = resPtr->cmdPtr;
|
| ︙ | ︙ | |||
4585 4586 4587 4588 4589 4590 4591 |
descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_SIZE_MODIFIER "d,"
" object pointer at %p",
objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
objv[1]->refCount, objv[1]);
if (objv[1]->typePtr) {
| | | | | 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 |
descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_SIZE_MODIFIER "d,"
" object pointer at %p",
objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
objv[1]->refCount, objv[1]);
if (objv[1]->typePtr) {
if (TclHasInternalRep(objv[1], &tclDoubleType)) {
Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
objv[1]->internalRep.doubleValue);
} else {
Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
(void *) objv[1]->internalRep.twoPtrValue.ptr1,
(void *) objv[1]->internalRep.twoPtrValue.ptr2);
}
}
if (objv[1]->bytes) {
Tcl_AppendToObj(descObj, ", string representation \"", -1);
Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
16, "...");
Tcl_AppendToObj(descObj, "\"", -1);
} else {
Tcl_AppendToObj(descObj, ", no string representation", -1);
}
Tcl_SetObjResult(interp, descObj);
return TCL_OK;
|
| ︙ | ︙ |
Changes to generic/tclOptimize.c.
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
LocateTargetAddresses(envPtr, &targets);
for (currentInstPtr = envPtr->codeStart ;
currentInstPtr < envPtr->codeNext ; currentInstPtr += size) {
int blank = 0, i, nextInst;
size = AddrLength(currentInstPtr);
while ((currentInstPtr + size < envPtr->codeNext)
| | | | | | | | | | 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 |
LocateTargetAddresses(envPtr, &targets);
for (currentInstPtr = envPtr->codeStart ;
currentInstPtr < envPtr->codeNext ; currentInstPtr += size) {
int blank = 0, i, nextInst;
size = AddrLength(currentInstPtr);
while ((currentInstPtr + size < envPtr->codeNext)
&& currentInstPtr[size] == INST_NOP) {
if (IsTargetAddress(&targets, currentInstPtr + size)) {
break;
}
size += InstLength(INST_NOP);
}
if (IsTargetAddress(&targets, currentInstPtr + size)) {
continue;
}
nextInst = currentInstPtr[size];
switch (*currentInstPtr) {
case INST_PUSH1:
if (nextInst == INST_POP) {
blank = size + InstLength(nextInst);
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
Tcl_Size numBytes;
(void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
case INST_PUSH4:
if (nextInst == INST_POP) {
blank = size + 1;
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt4AtPtr(currentInstPtr + 1));
Tcl_Size numBytes;
(void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
case INST_LNOT:
switch (nextInst) {
case INST_JUMP_TRUE1:
blank = size;
currentInstPtr[size] = INST_JUMP_FALSE1;
break;
case INST_JUMP_FALSE1:
blank = size;
currentInstPtr[size] = INST_JUMP_TRUE1;
break;
case INST_JUMP_TRUE4:
blank = size;
currentInstPtr[size] = INST_JUMP_FALSE4;
break;
case INST_JUMP_FALSE4:
blank = size;
currentInstPtr[size] = INST_JUMP_TRUE4;
break;
}
break;
case INST_TRY_CVT_TO_NUMERIC:
switch (nextInst) {
case INST_JUMP_TRUE1:
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 |
break;
}
break;
}
if (blank > 0) {
for (i=0 ; i<blank ; i++) {
| | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
break;
}
break;
}
if (blank > 0) {
for (i=0 ; i<blank ; i++) {
currentInstPtr[i] = INST_NOP;
}
size = blank;
}
}
Tcl_DeleteHashTable(&targets);
}
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
}
Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
if (!isNew) {
offset = TclGetInt1AtPtr(currentInstPtr + 1);
break;
}
offset += delta;
| | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
}
Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
if (!isNew) {
offset = TclGetInt1AtPtr(currentInstPtr + 1);
break;
}
offset += delta;
switch (currentInstPtr[offset]) {
case INST_NOP:
delta = InstLength(INST_NOP);
continue;
case INST_JUMP1:
delta = TclGetInt1AtPtr(currentInstPtr + offset + 1);
continue;
case INST_JUMP4:
|
| ︙ | ︙ | |||
390 391 392 393 394 395 396 |
Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew);
for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
if (!isNew) {
offset = TclGetInt4AtPtr(currentInstPtr + 1);
break;
}
| | | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew);
for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
if (!isNew) {
offset = TclGetInt4AtPtr(currentInstPtr + 1);
break;
}
switch (currentInstPtr[offset]) {
case INST_NOP:
offset += InstLength(INST_NOP);
continue;
case INST_JUMP1:
offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
continue;
case INST_JUMP4:
|
| ︙ | ︙ |
Changes to generic/tclPanic.c.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | #endif /* * The panicProc variable contains a pointer to an application specific panic * procedure. */ | | | | 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 |
#endif
/*
* The panicProc variable contains a pointer to an application specific panic
* procedure.
*/
static Tcl_PanicProc *panicProc = NULL;
/*
*----------------------------------------------------------------------
*
* Tcl_SetPanicProc --
*
* Replace the default panic behavior with the specified function.
*
* Results:
* None.
*
* Side effects:
* Sets the panicProc variable.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_SetPanicProc(
Tcl_PanicProc *proc)
{
panicProc = proc;
return Tcl_InitSubsystems();
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | /* * The following comment is here so that Coverity's static analyzer knows that * a Tcl_Panic() call can never return and avoids lots of false positives. */ /* coverity[+kill] */ | | < | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
/*
* The following comment is here so that Coverity's static analyzer knows that
* a Tcl_Panic() call can never return and avoids lots of false positives.
*/
/* coverity[+kill] */
TCL_NORETURN void
Tcl_Panic(
const char *format,
...)
{
va_list argList;
char *arg1, *arg2, *arg3; /* Additional arguments (variable in number)
* to pass to fprintf. */
char *arg4, *arg5, *arg6, *arg7, *arg8;
va_start(argList, format);
arg1 = va_arg(argList, char *);
arg2 = va_arg(argList, char *);
arg3 = va_arg(argList, char *);
arg4 = va_arg(argList, char *);
arg5 = va_arg(argList, char *);
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
#else
fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7,
arg8);
fprintf(stderr, "\n");
fflush(stderr);
#endif
| > | | | | | | | | | | | < | 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 |
tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
#else
fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7,
arg8);
fprintf(stderr, "\n");
fflush(stderr);
#endif
}
#if defined(__GNUC__)
__builtin_trap();
#elif defined(_WIN64)
__debugbreak();
#elif defined(_MSC_VER) && defined (_M_IX86)
_asm {int 3}
#elif defined(_WIN32)
DebugBreak();
#endif
#if defined(_WIN32)
ExitProcess(1);
#else
abort();
#endif
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local functions defined in this file:
*/
| | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local functions defined in this file:
*/
static int CommandComplete(const char *script, Tcl_Size numBytes);
static Tcl_Size ParseComment(const char *src, Tcl_Size numBytes,
Tcl_Parse *parsePtr);
static int ParseTokens(const char *src, Tcl_Size numBytes, int mask,
int flags, Tcl_Parse *parsePtr);
static Tcl_Size ParseWhiteSpace(const char *src, Tcl_Size numBytes,
int *incompletePtr, char *typePtr);
static Tcl_Size ParseAllWhiteSpace(const char *src, Tcl_Size numBytes,
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
* We have to convert here in case the user has put a backslash in
* front of a multi-byte utf-8 character. While this means nothing
* special, we shouldn't break up a correct utf-8 character. [Bug
* #217987] test subst-3.2
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
| | | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 |
* We have to convert here in case the user has put a backslash in
* front of a multi-byte utf-8 character. While this means nothing
* special, we shouldn't break up a correct utf-8 character. [Bug
* #217987] test subst-3.2
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[8];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
count = TclUtfToUniChar(utfBytes, &unichar) + 1;
}
result = unichar;
break;
}
done:
if (readPtr != NULL) {
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 | * None. * *---------------------------------------------------------------------- */ static int ParseTokens( | | | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseTokens(
const char *src, /* First character to parse. */
Tcl_Size numBytes, /* Max number of bytes to scan. */
int mask, /* Specifies when to stop parsing. The parse
* stops at the first unquoted character whose
* CHAR_TYPE contains any of the bits in
* mask. */
int flags, /* OR-ed bits indicating what substitutions to
* perform: TCL_SUBST_COMMANDS,
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
ch = *src;
while (numBytes && (braceCount>0 || ch != '}')) {
switch (ch) {
case '{': braceCount++; break;
case '}': braceCount--; break;
case '\\':
/* if 2 or more left, consume 2, else consume
| | | 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 |
ch = *src;
while (numBytes && (braceCount>0 || ch != '}')) {
switch (ch) {
case '{': braceCount++; break;
case '}': braceCount--; break;
case '\\':
/* if 2 or more left, consume 2, else consume
* just the \ and let it run into the end */
if (numBytes > 1) {
src++; numBytes--;
}
}
numBytes--;
src++;
ch= *src;
|
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 |
*
*----------------------------------------------------------------------
*/
const char *
Tcl_ParseVar(
Tcl_Interp *interp, /* Context for looking up variable. */
| | | 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 |
*
*----------------------------------------------------------------------
*/
const char *
Tcl_ParseVar(
Tcl_Interp *interp, /* Context for looking up variable. */
const char *start, /* Start of variable substitution. First
* character must be "$". */
const char **termPtr) /* If non-NULL, points to word to fill in with
* character just after last one in the
* variable specifier. */
{
Tcl_Obj *objPtr;
int code;
|
| ︙ | ︙ | |||
2202 2203 2204 2205 2206 2207 2208 |
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
Tcl_Size clPos;
if (result == 0) {
clPos = 0;
} else {
| | | 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 |
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
Tcl_Size clPos;
if (result == 0) {
clPos = 0;
} else {
(void)TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (Tcl_Size *)Tcl_Realloc(clPosition,
maxNumCL * sizeof(Tcl_Size));
}
|
| ︙ | ︙ | |||
2478 2479 2480 2481 2482 2483 2484 |
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
Tcl_Size length;
| | | 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 |
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
Tcl_Size length;
const char *script = TclGetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclParse.h.
1 | /* | | > | | | | | | | | | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
/*
* Minimal set of shared flag definitions and declarations so that multiple
* source files can make use of the parsing table in tclParse.c
*/
enum ParseTypeFlags {
TYPE_NORMAL = 0,
TYPE_SPACE = 0x1,
TYPE_COMMAND_END = 0x2,
TYPE_SUBS = 0x4,
TYPE_QUOTE = 0x8,
TYPE_CLOSE_PAREN = 0x10,
TYPE_CLOSE_BRACK = 0x20,
TYPE_BRACE = 0x40,
TYPE_OPEN_PAREN = 0x80,
TYPE_BAD_ARRAY_INDEX = (
TYPE_OPEN_PAREN | TYPE_CLOSE_PAREN | TYPE_QUOTE | TYPE_BRACE)
};
#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)]
MODULE_SCOPE const unsigned char tclCharTypeTable[];
|
Changes to generic/tclPathObj.c.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
/*
* Define the 'path' object type, which Tcl uses to represent file paths
* internally.
*/
static const Tcl_ObjType fsPathType = {
| | | | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
/*
* Define the 'path' object type, which Tcl uses to represent file paths
* internally.
*/
static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
/*
* struct FsPath --
*
* Internal representation of a Tcl_Obj of fsPathType
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
Tcl_Size curLen;
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
| | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
Tcl_Size curLen;
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
(void)TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
dirSep += 2;
oldDirSep = dirSep;
if (dirSep[0] != 0 && dirSep[1] == '.') {
goto again;
|
| ︙ | ︙ | |||
246 247 248 249 250 251 252 |
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
| | | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
(void)TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
if (zipVolumeLen) {
linkObj = NULL;
} else {
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 | /* * Got a link. Need to check if the link is relative * or absolute, for those platforms where relative * links exist. */ if (tclPlatform != TCL_PLATFORM_WINDOWS | | < | | | | | 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 |
/*
* Got a link. Need to check if the link is relative
* or absolute, for those platforms where relative
* links exist.
*/
if (tclPlatform != TCL_PLATFORM_WINDOWS
&& Tcl_FSGetPathType(linkObj) == TCL_PATH_RELATIVE) {
/*
* We need to follow this link which is relative
* to retVal's directory. This means concatenating
* the link onto the directory of the path so far.
*/
const char *path =
TclGetStringFromObj(retVal, &curLen);
while (curLen-- > 0) {
if (IsSeparatorOrNull(path[curLen])) {
break;
}
}
/*
* We want the trailing slash.
*/
Tcl_SetObjLength(retVal, curLen+1);
Tcl_AppendObjToObj(retVal, linkObj);
TclDecrRefCount(linkObj);
linkStr = TclGetStringFromObj(retVal, &curLen);
} else {
/*
* Absolute link.
*/
TclDecrRefCount(retVal);
if (Tcl_IsShared(linkObj)) {
retVal = Tcl_DuplicateObj(linkObj);
TclDecrRefCount(linkObj);
} else {
retVal = linkObj;
}
linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
Tcl_Size i;
for (i = 0; i < curLen; i++) {
if (linkStr[i] == '\\') {
linkStr[i] = '/';
}
}
}
}
} else {
linkStr = TclGetStringFromObj(retVal, &curLen);
}
/*
* Either way, we now remove the last path element (but
* not the first character of the path). In the case of
* zipfs, make sure not to go beyond the zipfs volume.
*/
|
| ︙ | ︙ | |||
400 401 402 403 404 405 406 |
/*
* Ensure a windows drive like C:/ has a trailing separator.
* Likewise for zipfs volumes.
*/
if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
int needTrailingSlash = 0;
Tcl_Size len;
| | | > | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
/*
* Ensure a windows drive like C:/ has a trailing separator.
* Likewise for zipfs volumes.
*/
if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
int needTrailingSlash = 0;
Tcl_Size len;
const char *path = TclGetStringFromObj(retVal, &len);
if (zipVolumeLen) {
if (len == (zipVolumeLen - 1)) {
needTrailingSlash = 1;
}
} else {
if (len == 2 && path[0] != 0 && path[1] == ':') {
needTrailingSlash = 1;
}
}
if (needTrailingSlash) {
if (Tcl_IsShared(retVal)) {
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 | * it. If so, the 'dirname' would be a joining of the main * part with the dirname of the joined-on bit. We could handle * that special case here, but we don't, and instead just use * the standardPath code. */ Tcl_Size numBytes; | | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 |
* it. If so, the 'dirname' would be a joining of the main
* part with the dirname of the joined-on bit. We could handle
* that special case here, but we don't, and instead just use
* the standardPath code.
*/
Tcl_Size numBytes;
const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file dirname] is
* documented to return all but the last non-empty element
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | * Check if the joined-on bit has any directory delimiters in * it. If so, the 'tail' would be only the part following the * last delimiter. We could handle that special case here, but * we don't, and instead just use the standardPath code. */ Tcl_Size numBytes; | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
* Check if the joined-on bit has any directory delimiters in
* it. If so, the 'tail' would be only the part following the
* last delimiter. We could handle that special case here, but
* we don't, and instead just use the standardPath code.
*/
Tcl_Size numBytes;
const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file tail] is
* documented to return the last non-empty element
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
Tcl_Size length;
| | | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
Tcl_Size length;
fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
/*
* There is no extension so the root is the same as the
* path we were given.
*/
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 |
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
Tcl_Size length;
const char *fileName, *extension;
| | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
Tcl_Size length;
const char *fileName, *extension;
fileName = TclGetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
return pathPtr;
} else {
Tcl_Obj *root = Tcl_NewStringObj(fileName,
length - strlen(extension));
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | * Tcl_FSSplitPath preserves the "~", but this code computes the * actual full path name, if we had just a single component. */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
* Tcl_FSSplitPath preserves the "~", but this code computes the
* actual full path name, if we had just a single component.
*/
splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
Tcl_IncrRefCount(splitPtr);
if (portion == TCL_PATH_TAIL) {
/*
* Return the last component, unless it is the only component, and
* it is the root of an absolute path.
*/
if ((splitElements > 0) && ((splitElements > 1) ||
(Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
* reference count. */
Tcl_Size elements) /* Number of elements to use (-1 = all) */
{
Tcl_Obj *res;
Tcl_Size objc;
Tcl_Obj **objv;
| | | | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
* reference count. */
Tcl_Size elements) /* Number of elements to use (-1 = all) */
{
Tcl_Obj *res;
Tcl_Size objc;
Tcl_Obj **objv;
if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) {
return NULL;
}
elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
TclListObjGetElements(NULL, listObj, &objc, &objv);
res = TclJoinPath(elements, objv, 0);
return res;
}
Tcl_Obj *
TclJoinPath(
Tcl_Size elements, /* Number of elements to use */
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
/* if forceRelative - second path is relative */
type = forceRelative ? TCL_PATH_RELATIVE :
TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
Tcl_Size len;
| | | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 |
/* if forceRelative - second path is relative */
type = forceRelative ? TCL_PATH_RELATIVE :
TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
Tcl_Size len;
str = TclGetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
* There's no need to return a special path object, when
* the base itself is just fine!
*/
|
| ︙ | ︙ | |||
951 952 953 954 955 956 957 | Tcl_Size driveNameLength; Tcl_Size strEltLen, length; Tcl_PathType type; char *strElt, *ptr; Tcl_Obj *driveName = NULL; Tcl_Obj *elt = objv[i]; | | | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 |
Tcl_Size driveNameLength;
Tcl_Size strEltLen, length;
Tcl_PathType type;
char *strElt, *ptr;
Tcl_Obj *driveName = NULL;
Tcl_Obj *elt = objv[i];
strElt = TclGetStringFromObj(elt, &strEltLen);
driveNameLength = 0;
/* if forceRelative - all paths excepting first one are relative */
type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/*
* Zero out the current result.
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 |
* We need to perform a more complex operation here.
*/
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
| | | | | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
* We need to perform a more complex operation here.
*/
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
ptr = TclGetStringFromObj(res, &length);
/*
* A NULL value for fsPtr at this stage basically means we're trying
* to join a relative path onto something which is also relative (or
* empty). There's nothing particularly wrong with that.
*/
if (*strElt == '\0') {
continue;
}
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
| | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
(void)TclGetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + strlen(strElt));
ptr = TclGetString(res) + length;
for (; *strElt != '\0'; strElt++) {
if (*strElt == separator) {
while (strElt[1] == separator) {
|
| ︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 |
* This is likely buggy when dealing with virtual filesystem drivers
* that use some character other than "/" as a path separator. I know
* of no evidence that such a foolish thing exists. This solution was
* chosen so that "JoinPath" operations that pass through either path
* internalrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
| | | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 |
* This is likely buggy when dealing with virtual filesystem drivers
* that use some character other than "/" as a path separator. I know
* of no evidence that such a foolish thing exists. This solution was
* chosen so that "JoinPath" operations that pass through either path
* internalrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
bytes = TclGetStringFromObj(tail, &length);
if (length == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
TclpNativeJoinPath(copy, bytes);
}
return copy;
}
|
| ︙ | ︙ | |||
1408 1409 1410 1411 1412 1413 1414 |
* better test than the '!= sep' might be to simply check if 'cwd' is a
* root volume.
*
* Note that if we get this wrong, we will strip off either too much or
* too little below, leading to wrong answers returned by glob.
*/
| | | | 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 |
* better test than the '!= sep' might be to simply check if 'cwd' is a
* root volume.
*
* Note that if we get this wrong, we will strip off either too much or
* too little below, leading to wrong answers returned by glob.
*/
tempStr = TclGetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
* Windows special case? Perhaps we should just check if cwd is a root
* volume.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (tempStr[cwdLen-1] != '/') {
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') {
cwdLen++;
}
break;
}
tempStr = TclGetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 |
Tcl_Obj *
Tcl_FSNewNativePath(
const Tcl_Filesystem *fromFilesystem,
void *clientData)
{
Tcl_Obj *pathPtr = NULL;
FsPath *fsPathPtr;
| < | 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 |
Tcl_Obj *
Tcl_FSNewNativePath(
const Tcl_Filesystem *fromFilesystem,
void *clientData)
{
Tcl_Obj *pathPtr = NULL;
FsPath *fsPathPtr;
if (fromFilesystem->internalToNormalizedProc != NULL) {
pathPtr = (*fromFilesystem->internalToNormalizedProc)(clientData);
}
if (pathPtr == NULL) {
return NULL;
}
|
| ︙ | ︙ | |||
1654 1655 1656 1657 1658 1659 1660 |
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
Tcl_Size len;
| | | 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 |
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
Tcl_Size len;
const char *orig = TclGetStringFromObj(transPtr, &len);
char *result = (char *)Tcl_Alloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
return result;
}
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 |
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
/* TODO: Figure out why this is needed. */
TclGetString(pathPtr);
| | | | 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 |
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
/* TODO: Figure out why this is needed. */
TclGetString(pathPtr);
(void)TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
copy = Tcl_DuplicateObj(dir);
}
Tcl_IncrRefCount(dir);
Tcl_IncrRefCount(copy);
/*
* We now own a reference on both 'dir' and 'copy'
*/
(void) TclGetStringFromObj(dir, &cwdLen);
/* Normalize the combined string. */
if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) {
/*
* If the "tail" part has components (like /../) that cause the
* combined path to need more complete normalizing, call on the
|
| ︙ | ︙ | |||
1810 1811 1812 1813 1814 1815 1816 |
fsPathPtr = PATHOBJ(pathPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
Tcl_Size cwdLen;
Tcl_Obj *copy;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
| | | 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 |
fsPathPtr = PATHOBJ(pathPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
Tcl_Size cwdLen;
Tcl_Obj *copy;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
(void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (TclGetString(copy)[cwdLen] == '/');
/*
* Normalize the combined string, but only starting after the end
* of the previously normalized 'dir'. This should be much faster!
*/
|
| ︙ | ︙ | |||
2148 2149 2150 2151 2152 2153 2154 |
if (firstPtr == secondPtr) {
return 1;
}
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
| | | | | | 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 |
if (firstPtr == secondPtr) {
return 1;
}
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = TclGetStringFromObj(firstPtr, &firstLen);
secondStr = TclGetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) {
return 1;
}
/*
* Try the most thorough, correct method of comparing fully normalized
* paths.
*/
tempErrno = Tcl_GetErrno();
firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
Tcl_SetErrno(tempErrno);
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = TclGetStringFromObj(firstPtr, &firstLen);
secondStr = TclGetStringFromObj(secondPtr, &secondLen);
return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
}
/*
*---------------------------------------------------------------------------
*
* SetFsPathFromAny --
|
| ︙ | ︙ | |||
2217 2218 2219 2220 2221 2222 2223 |
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and one has to make
* sure not to break anything on Unix or Win (fCmd.test, fileName.test and
* cmdAH.test exercise most of the code).
*/
| | | 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 |
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and one has to make
* sure not to break anything on Unix or Win (fCmd.test, fileName.test and
* cmdAH.test exercise most of the code).
*/
TclGetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */
transPtr = TclJoinPath(1, &pathPtr, 1);
/*
* Now we have a translated filename in 'transPtr'. This will have forward
* slashes on Windows, and will not contain any ~user sequences.
*/
|
| ︙ | ︙ | |||
2344 2345 2346 2347 2348 2349 2350 | * Memory may be allocated. * *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 |
* Memory may be allocated.
*
*---------------------------------------------------------------------------
*/
static void
UpdateStringOfFsPath(
Tcl_Obj *pathPtr) /* path obj with string rep to update. */
{
FsPath *fsPathPtr = PATHOBJ(pathPtr);
Tcl_Size cwdLen;
Tcl_Obj *copy;
if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
if (fsPathPtr->translatedPathPtr == NULL) {
|
| ︙ | ︙ | |||
2366 2367 2368 2369 2370 2371 2372 |
if (Tcl_IsShared(copy)) {
copy = Tcl_DuplicateObj(copy);
}
Tcl_IncrRefCount(copy);
/* Steal copy's string rep */
| | | 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 |
if (Tcl_IsShared(copy)) {
copy = Tcl_DuplicateObj(copy);
}
Tcl_IncrRefCount(copy);
/* Steal copy's string rep */
pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
TclInitEmptyStringRep(copy);
TclDecrRefCount(copy);
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2426 2427 2428 2429 2430 2431 2432 | * It is somewhat unusual to reach this code path without the object * being of fsPathType. However, we do our best to deal with the * situation. */ Tcl_Size len; | | | 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 |
* It is somewhat unusual to reach this code path without the object
* being of fsPathType. However, we do our best to deal with the
* situation.
*/
Tcl_Size len;
(void) TclGetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
*/
return -1;
}
|
| ︙ | ︙ | |||
2466 2467 2468 2469 2470 2471 2472 | * Returns TCL_OK on success with home directory path in *dsPtr * and TCL_ERROR on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ int MakeTildeRelativePath( | | | | | | | | | | | | | | | | | | | | | | | | 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 |
* Returns TCL_OK on success with home directory path in *dsPtr
* and TCL_ERROR on failure with error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
int
MakeTildeRelativePath(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
const char *user, /* User name. NULL -> current user */
const char *subPath, /* Rest of path. May be NULL */
Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must
* be freed on success */
{
const char *dir;
Tcl_DString dirString;
Tcl_DStringInit(dsPtr);
Tcl_DStringInit(&dirString);
if (user == NULL || user[0] == 0) {
/* No user name specified -> current user */
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't find HOME environment variable to expand path",
-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
"HOMELESS", (char *)NULL);
}
return TCL_ERROR;
}
} else {
/* User name specified - ~user */
dir = TclpGetUserHome(user, &dirString);
if (dir == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"user \"%s\" doesn't exist", user));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
(char *)NULL);
}
return TCL_ERROR;
}
}
if (subPath) {
const char *parts[2];
parts[0] = dir;
parts[1] = subPath;
Tcl_JoinPath(2, parts, dsPtr);
|
| ︙ | ︙ | |||
2534 2535 2536 2537 2538 2539 2540 | * Returns a Tcl_Obj containing the home directory of a user * or NULL on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetHomeDirObj( | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 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 |
* Returns a Tcl_Obj containing the home directory of a user
* or NULL on failure with error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetHomeDirObj(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
const char *user) /* User name. NULL -> current user */
{
Tcl_DString dirString;
if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) {
return NULL;
}
return Tcl_DStringToObj(&dirString);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSTildeExpand --
*
* Copies the path passed in to the output Tcl_DString dsPtr,
* resolving leading ~ and ~user components in the path if present.
* An error is returned if such a component IS present AND cannot
* be resolved.
*
* The output dsPtr must be cleared by caller on success.
*
* Results:
* TCL_OK - path did not contain leading ~ or it was successful resolved
* TCL_ERROR - ~ component could not be resolved.
*
*----------------------------------------------------------------------
*/
int Tcl_FSTildeExpand(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
const char *path, /* Path to resolve tilde */
Tcl_DString *dsPtr) /* Output DString for resolved path. */
{
Tcl_Size split;
int result;
assert(path);
assert(dsPtr);
Tcl_DStringInit(dsPtr);
if (path[0] != '~') {
Tcl_DStringAppend(dsPtr, path, -1);
return TCL_OK;
}
/*
* We have multiple cases '~', '~user', '~/foo/bar...', '~user/foo...'
* FindSplitPos returns 1 for '~/...' as well as for '~'. Note on
* Windows FindSplitPos implicitly checks for '\' as separator
* in addition to what is passed.
*/
split = FindSplitPos(path, '/');
if (split == 1) {
/* No user name specified '~' or '~/...' -> current user */
result = MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL, dsPtr);
} else {
/* User name specified - ~user, ~user/... */
const char *user;
Tcl_DString dsUser;
Tcl_DStringInit(&dsUser);
Tcl_DStringAppend(&dsUser, path+1, split-1);
user = Tcl_DStringValue(&dsUser);
/* path[split] is / for ~user/... or \0 for ~user */
result = MakeTildeRelativePath(interp, user,
path[split] ? &path[split + 1] : NULL, dsPtr);
Tcl_DStringFree(&dsUser);
}
if (result != TCL_OK) {
/* Do not rely on caller to free in case of errors */
Tcl_DStringFree(dsPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclResolveTildePath --
*
* If the passed path is begins with a tilde, does tilde resolution
|
| ︙ | ︙ | |||
2566 2567 2568 2569 2570 2571 2572 | * Returns NULL if the path begins with a ~ that cannot be resolved * and stores an error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclResolveTildePath( | | < | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | | < | | 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 |
* Returns NULL if the path begins with a ~ that cannot be resolved
* and stores an error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclResolveTildePath(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
Tcl_Obj *pathObj)
{
const char *path;
Tcl_Size len;
Tcl_DString resolvedPath;
path = TclGetStringFromObj(pathObj, &len);
/* Optimize to skip unnecessary calls below */
if (path[0] != '~') {
return pathObj;
}
if (Tcl_FSTildeExpand(interp, path, &resolvedPath) != TCL_OK) {
return NULL;
}
return Tcl_DStringToObj(&resolvedPath);
}
/*
*----------------------------------------------------------------------
*
* TclResolveTildePathList --
|
| ︙ | ︙ | |||
2653 2654 2655 2656 2657 2658 2659 |
Tcl_Obj **objv;
Tcl_Size objc;
Tcl_Size i;
Tcl_Obj *resolvedPaths;
const char *path;
if (pathsObj == NULL) {
| | | | | | | | | < | 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 |
Tcl_Obj **objv;
Tcl_Size objc;
Tcl_Size i;
Tcl_Obj *resolvedPaths;
const char *path;
if (pathsObj == NULL) {
return NULL;
}
if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) {
return NULL; /* Not a list */
}
/*
* Figure out if any paths need resolving to avoid unnecessary allocations.
*/
for (i = 0; i < objc; ++i) {
path = Tcl_GetString(objv[i]);
if (path[0] == '~') {
break; /* At least one path needs resolution */
}
}
if (i == objc) {
return pathsObj; /* No paths needed to be resolved */
}
resolvedPaths = Tcl_NewListObj(objc, NULL);
for (i = 0; i < objc; ++i) {
Tcl_Obj *resolvedPath;
path = Tcl_GetString(objv[i]);
if (path[0] == 0) {
continue; /* Skip empty strings */
}
resolvedPath = TclResolveTildePath(NULL, objv[i]);
if (resolvedPath) {
/* Paths that cannot be resolved are skipped */
Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath);
}
}
return resolvedPaths;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclPipe.c.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
Tcl_SetObjResult(interp, msg);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for %s",
Tcl_GetChannelName(chan),
((writing) ? "writing" : "reading")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
| | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
Tcl_SetObjResult(interp, msg);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for %s",
Tcl_GetChannelName(chan),
((writing) ? "writing" : "reading")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADCHAN", (char *)NULL);
}
return NULL;
}
*releasePtr = 1;
if (writing) {
/*
* Be sure to flush output to the file, so that anything written
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
*closePtr = 1;
}
return file;
badLastArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't specify \"%s\" as last word in command", arg));
| | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
*closePtr = 1;
}
return file;
badLastArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't specify \"%s\" as last word in command", arg));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", (char *)NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DetachPids --
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 |
p++;
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
| | | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
p++;
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", (char *)NULL);
goto error;
}
}
lastBar = i;
cmdCount++;
needCmd = 1;
break;
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 |
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
| | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", (char *)NULL);
goto error;
}
skip = 2;
}
} else {
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
inputLiteral = NULL;
|
| ︙ | ︙ | |||
656 657 658 659 660 661 662 |
*/
if (i != argc-1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"must specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
| | | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 |
*/
if (i != argc-1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"must specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", (char *)NULL);
goto error;
}
errorFile = outputFile;
errorToOutput = 2;
skip = 1;
} else {
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 | /* * We had a bar followed only by redirections. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", | | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
/*
* We had a bar followed only by redirections.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
(char *)NULL);
goto error;
}
if (inputFile == NULL) {
if (inputLiteral != NULL) {
/*
* The input for the first process is immediate data coming from
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_OpenCommandChannel(
Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be
* NULL. */
| | | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_OpenCommandChannel(
Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be
* NULL. */
Tcl_Size argc, /* How many arguments. */
const char **argv, /* Array of arguments for command pipe. */
int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
* TCL_STDERR, and TCL_ENFORCE_MODE. */
{
TclFile *inPipePtr, *outPipePtr, *errFilePtr;
TclFile inPipe, outPipe, errFile;
Tcl_Size numPids;
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
if (flags & TCL_ENFORCE_MODE) {
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't read output from command:"
" standard output was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
| | | | | 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 |
if (flags & TCL_ENFORCE_MODE) {
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't read output from command:"
" standard output was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", (char *)NULL);
goto error;
}
if ((flags & TCL_STDIN) && (inPipe == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't write input to command:"
" standard input was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", (char *)NULL);
goto error;
}
}
channel = TclpCreateCommandChannel(outPipe, inPipe, errFile,
numPids, pidPtr);
if (channel == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"pipe for command could not be created", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", (char *)NULL);
goto error;
}
return channel;
error:
if (pidPtr) {
Tcl_DetachPids(numPids, pidPtr);
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
pkgPtr->clientData = clientData;
}
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"conflicting versions provided for package \"%s\": %s, then %s",
name, Tcl_GetString(pkgPtr->version), version));
| | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
pkgPtr->clientData = clientData;
}
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"conflicting versions provided for package \"%s\": %s, then %s",
name, Tcl_GetString(pkgPtr->version), version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 | * reliably, so be very careful about adding any other calls here * without checking how they behave when initialization is incomplete. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); | | | | 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 |
* reliably, so be very careful about adding any other calls here
* without checking how they behave when initialization is incomplete.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Cannot load package \"%s\" in standalone executable:"
" This package is not compiled with stub support", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", (char *)NULL);
return NULL;
}
/*
* Translate between old and new API, and defer to the new function.
*/
if (version == NULL) {
if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) {
result = Tcl_GetStringResult(interp);
Tcl_ResetResult(interp);
}
} else {
if (exact && TCL_OK
!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
return NULL;
}
ov = Tcl_NewStringObj(version, -1);
if (exact) {
Tcl_AppendStringsToObj(ov, "-", version, (char *)NULL);
}
Tcl_IncrRefCount(ov);
if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
result = Tcl_GetStringResult(interp);
Tcl_ResetResult(interp);
}
TclDecrRefCount(ov);
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, script, -1);
Tcl_DStringAppendElement(&command, name);
AddRequirementsToDString(&command, reqc, reqv);
Tcl_NRAddCallback(interp,
PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
| | < < < < | | 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 |
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, script, -1);
Tcl_DStringAppendElement(&command, name);
AddRequirementsToDString(&command, reqc, reqv);
Tcl_NRAddCallback(interp,
PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
Tcl_NREvalObj(interp, Tcl_DStringToObj(&command), TCL_EVAL_GLOBAL);
return TCL_OK;
}
static int
PkgRequireCoreStep2(
void *data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = (Require *)data[0];
int reqc = (int)PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name; /* Name of desired package. */
if ((result != TCL_OK) && (result != TCL_ERROR)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad return code: %d", result));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (char *)NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp,
"\n (\"package unknown\" script)");
return result;
}
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
char *pkgVersionI;
void *clientDataPtr = reqPtr->clientDataPtr;
const char *name = reqPtr->name; /* Name of desired package. */
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
| | | | 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 |
char *pkgVersionI;
void *clientDataPtr = reqPtr->clientDataPtr;
const char *name = reqPtr->name; /* Name of desired package. */
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", (char *)NULL);
AddRequirementsToResult(interp, reqc, reqv);
return TCL_ERROR;
}
/*
* Ensure that the provided version meets the current requirements.
*/
if (reqc != 0) {
CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version),
&pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
Tcl_Free(pkgVersionI);
if (!satisfies) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"version conflict for package \"%s\": have %s, need",
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
(char *)NULL);
AddRequirementsToResult(interp, reqc, reqv);
return TCL_ERROR;
}
}
if (clientDataPtr) {
const void **ptr = (const void **) clientDataPtr;
|
| ︙ | ︙ | |||
666 667 668 669 670 671 672 |
if (pkgPtr->clientData != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"circular package dependency:"
" attempt to provide %s %s requires %s",
name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
| | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
if (pkgPtr->clientData != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"circular package dependency:"
" attempt to provide %s %s requires %s",
name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", (char *)NULL);
return TCL_ERROR;
}
/*
* The package isn't yet present. Search the list of available versions
* and invoke the script for the best available version. We are actually
* locating the best, and the best stable version. One of them is then
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
if (reqPtr->pkgPtr->version == NULL) {
result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" no version of package %s provided",
name, versionToProvide, name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
| | | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
if (reqPtr->pkgPtr->version == NULL) {
result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" no version of package %s provided",
name, versionToProvide, name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
(char *)NULL);
} else {
char *pvi, *vi;
if (TCL_OK != CheckVersionAndConvert(interp,
Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) {
result = TCL_ERROR;
} else if (CheckVersionAndConvert(interp,
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 | result = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, name, Tcl_GetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", | | | | 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 |
result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" package %s %s provided instead",
name, versionToProvide,
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", (char *)NULL);
}
}
}
} else if (result != TCL_ERROR) {
Tcl_Obj *codePtr;
TclNewIntObj(codePtr, result);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" bad return code: %s",
name, versionToProvide, TclGetString(codePtr)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (char *)NULL);
TclDecrRefCount(codePtr);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"package ifneeded %s %s\" script)",
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
*/
const char *foundVersion = Tcl_PkgRequireEx(interp, name, version,
exact, clientDataPtr);
if (foundVersion == NULL) {
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name,
| | | | 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 |
*/
const char *foundVersion = Tcl_PkgRequireEx(interp, name, version,
exact, clientDataPtr);
if (foundVersion == NULL) {
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name,
(char *)NULL);
}
return foundVersion;
}
}
if (version != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"package %s %s is not present", name, version));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"package %s is not present", name));
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, (char *)NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PackageObjCmd --
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
Tcl_Free(argv3i);
return TCL_OK;
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
| | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
Tcl_Free(argv3i);
return TCL_OK;
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = TclGetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
NULL) != TCL_OK) {
Tcl_Free(argv3i);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1226 1227 1228 1229 1230 1231 1232 |
pkgPtr->availPtr = availPtr;
} else {
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
}
}
if (iPtr->scriptFile) {
| | | | 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
pkgPtr->availPtr = availPtr;
} else {
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
}
}
if (iPtr->scriptFile) {
argv4 = TclGetStringFromObj(iPtr->scriptFile, &length);
DupBlock(availPtr->pkgIndex, argv4, length + 1);
}
argv4 = TclGetStringFromObj(objv[4], &length);
DupBlock(availPtr->script, argv4, length + 1);
break;
}
case PKG_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 | } /* * Create a new-style requirement for the exact version. */ ov = Tcl_NewStringObj(version, -1); | | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 | } /* * Create a new-style requirement for the exact version. */ ov = Tcl_NewStringObj(version, -1); Tcl_AppendStringsToObj(ov, "-", version, (char *)NULL); version = NULL; argv3 = TclGetString(objv[3]); Tcl_IncrRefCount(objv[3]); objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *) argv3, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; |
| ︙ | ︙ | |||
1385 1386 1387 1388 1389 1390 1391 | * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } | | | | 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 |
* Tcl_Obj structures may have come from another interpreter,
* so duplicate them.
*/
Tcl_ListObjAppendElement(interp, objvListPtr,
Tcl_DuplicateObj(newobjv[i]));
}
TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
Tcl_NRAddCallback(interp,
TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL);
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
}
break;
case PKG_UNKNOWN: {
Tcl_Size length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
Tcl_Free(iPtr->packageUnknown);
}
argv2 = TclGetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
DupBlock(iPtr->packageUnknown, argv2, length+1);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 |
return TCL_OK;
}
error:
Tcl_Free(ibuf);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected version number but got \"%s\"", string));
| | | 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 |
return TCL_OK;
}
error:
Tcl_Free(ibuf);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected version number but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* CompareVersions --
|
| ︙ | ︙ | |||
2015 2016 2017 2018 2019 2020 2021 |
if (strchr(dash+1, '-') != NULL) {
/*
* More dashes found after the first. This is wrong.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected versionMin-versionMax but got \"%s\"", string));
| | | 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 |
if (strchr(dash+1, '-') != NULL) {
/*
* More dashes found after the first. This is wrong.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected versionMin-versionMax but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", (char *)NULL);
return TCL_ERROR;
}
/*
* Exactly one dash is present. Copy the string, split at the location of
* dash and check that both parts are versions. Note that the max part can
* be empty. Also note that the string allocated with strdup() must be
|
| ︙ | ︙ | |||
2071 2072 2073 2074 2075 2076 2077 |
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i;
Tcl_Size length;
for (i = 0; i < reqc; i++) {
| | | 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 |
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i;
Tcl_Size length;
for (i = 0; i < reqc; i++) {
const char *v = TclGetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2));
} else {
Tcl_AppendPrintfToObj(result, " %s", v);
}
|
| ︙ | ︙ |
Changes to generic/tclPkgConfig.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | * * - TCL_THREADS OSCMa compilation as threaded core. * - TCL_MEM_DEBUG OSCMa memory debugging. * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | * * - TCL_THREADS OSCMa compilation as threaded core. * - TCL_MEM_DEBUG OSCMa memory debugging. * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. * - NDEBUG NSCMdt tcl is compiled with symbol info off. * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * * - CFG_RUNTIME_* Paths to various stuff at runtime. * - CFG_INSTALL_* Paths to various stuff at installation time. * * - TCL_CFGVAL_ENCODING string containing the encoding used for the |
| ︙ | ︙ |
Changes to generic/tclPreserve.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
/*
* The following data structure is used to keep track of all the Tcl_Preserve
* calls that are still in effect. It grows as needed to accommodate any
* number of calls in effect.
*/
typedef struct {
| | | > | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
/*
* The following data structure is used to keep track of all the Tcl_Preserve
* calls that are still in effect. It grows as needed to accommodate any
* number of calls in effect.
*/
typedef struct {
void *clientData; /* Address of preserved block. */
size_t refCount; /* Number of Tcl_Preserve calls in effect for
* block. */
int mustFree; /* Non-zero means Tcl_EventuallyFree was
* called while a Tcl_Preserve call was in
* effect, so the structure must be freed when
* refCount becomes zero. */
Tcl_FreeProc *freeProc; /* Function to call to free. */
} Reference;
/*
* Global data structures used to hold the list of preserved data references.
* These variables are protected by "preserveMutex".
*/
static Reference *refArray = NULL;
/* First in array of references. */
static size_t spaceAvl = 0; /* Total number of structures available at
* *firstRefPtr. */
static size_t inUse = 0; /* Count of structures currently in use in
* refArray. */
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */
#define INITIAL_SIZE 2 /* Initial number of reference slots to make */
/*
* The following data structure is used to keep track of whether an arbitrary
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 | * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void Tcl_Preserve( | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
* until at least the matching call to Tcl_Release.
*
*----------------------------------------------------------------------
*/
void
Tcl_Preserve(
void *clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
size_t i;
/*
* See if there is already a reference for this pointer. If so, just
* increment its reference count.
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 | * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ void Tcl_Release( | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
* call to Tcl_Preserve is still in effect, the block of memory is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_Release(
void *clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
size_t i;
Tcl_MutexLock(&preserveMutex);
for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
int mustFree;
|
| ︙ | ︙ | |||
255 256 257 258 259 260 261 | * Ptr may be released by calling free(). * *---------------------------------------------------------------------- */ void Tcl_EventuallyFree( | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
* Ptr may be released by calling free().
*
*----------------------------------------------------------------------
*/
void
Tcl_EventuallyFree(
void *clientData, /* Pointer to malloc'ed block of memory. */
Tcl_FreeProc *freeProc) /* Function to actually do free. */
{
Reference *refPtr;
size_t i;
/*
* See if there is a reference for this pointer. If so, set its "mustFree"
|
| ︙ | ︙ |
Changes to generic/tclProc.c.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 |
* Tcl_GetStringFromObj should panic
* instead. */
NULL, /* SetFromAny function; Tcl_ConvertToType
* should panic instead. */
TCL_OBJTYPE_V0
};
| | | | | | > > > > | | | | | | | | < | 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 |
* Tcl_GetStringFromObj should panic
* instead. */
NULL, /* SetFromAny function; Tcl_ConvertToType
* should panic instead. */
TCL_OBJTYPE_V0
};
#define ProcSetInternalRep(objPtr, procPtr) \
do { \
Tcl_ObjInternalRep ir; \
(procPtr)->refCount++; \
ir.twoPtrValue.ptr1 = (procPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &tclProcBodyType, &ir); \
} while (0)
#define ProcGetInternalRep(objPtr, procPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &tclProcBodyType); \
(procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The [upvar]/[uplevel] level reference type. Uses the wideValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
* rep; it's just a cache type.
*/
static const Tcl_ObjType levelReferenceType = {
"levelReference",
NULL,
NULL,
NULL,
NULL,
TCL_OBJTYPE_V1(TclLengthOne)
};
/*
* The type of lambdas. Note that every lambda will *always* have a string
* representation.
*
* Internally, ptr1 is a pointer to a Proc instance that is not bound to a
* command name, and ptr2 is a pointer to the namespace that the Proc instance
* will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
*/
static const Tcl_ObjType lambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetLambdaFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (procPtr); \
ir.twoPtrValue.ptr2 = (nsObjPtr); \
Tcl_IncrRefCount((nsObjPtr)); \
Tcl_StoreInternalRep((objPtr), &lambdaType, &ir); \
} while (0)
#define LambdaGetInternalRep(objPtr, procPtr, nsObjPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &lambdaType); \
(procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
(nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_ProcObjCmd --
*
* This object-based function is invoked to process the "proc" Tcl
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
*/
#undef TclObjInterpProc
int
Tcl_ProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
*/
#undef TclObjInterpProc
int
Tcl_ProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
const char *procName;
const char *simpleName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
TclGetNamespaceForQualName(interp, procName, NULL, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
procName));
| | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
TclGetNamespaceForQualName(interp, procName, NULL, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL);
return TCL_ERROR;
}
if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL);
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | procArgs++; } /* * The argument list is just "args"; check the body */ | | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
procArgs++;
}
/*
* The argument list is just "args"; check the body
*/
procBody = TclGetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
/*
* The body is just spaces: link the compileProc
*/
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
*/
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
Tcl_Size length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
| | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
*/
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
Tcl_Size length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
/*
* TIP #280.
* Ensure that the continuation line data for the original body is
* not lost and applies to the new body as well.
*/
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
/*
* Break up the argument list into argument specifiers, then process each
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
*/
| | | | | | | | | | | | 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 |
/*
* Break up the argument list into argument specifiers, then process each
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
*/
result = TclListObjGetElements(interp, argsPtr, &numArgs, &argArray);
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", (char *)NULL);
goto procError;
}
localPtr = procPtr->firstLocalPtr;
} else {
procPtr->numArgs = numArgs;
procPtr->numCompiledLocals = numArgs;
}
for (i = 0; i < numArgs; i++) {
const char *argname, *argnamei, *argnamelast;
Tcl_Size fieldCount, nameLength;
Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
result = TclListObjGetElements(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
Tcl_Obj *errorObj = Tcl_NewStringObj(
"too many fields in argument specifier \"", -1);
Tcl_AppendObjToObj(errorObj, argArray[i]);
Tcl_AppendToObj(errorObj, "\"", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", (char *)NULL);
goto procError;
}
if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", (char *)NULL);
goto procError;
}
argname = TclGetStringFromObj(fieldValues[0], &nameLength);
/*
* Check that the formal parameter name is a scalar.
*/
argnamei = argname;
argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;
while (argnamei < argnamelast) {
if (*argnamei == '(') {
if (*argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
TclGetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", (char *)NULL);
goto procError;
}
} else if (argnamei[0] == ':' && argnamei[1] == ':') {
Tcl_Obj *errorObj = Tcl_NewStringObj(
"formal parameter \"", -1);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", (char *)NULL);
goto procError;
}
argnamei++;
}
if (precompiled) {
/*
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 |
|| !(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",
| | | | | < | | 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 |
|| !(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", (char *)NULL);
goto procError;
}
/*
* Compare the default value if any.
*/
if (localPtr->defValuePtr != NULL) {
Tcl_Size tmpLength, valueLength;
const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength);
const char *value = TclGetStringFromObj(fieldValues[1], &valueLength);
if ((valueLength != tmpLength)
|| memcmp(value, tmpPtr, tmpLength) != 0) {
Tcl_Obj *errorObj = Tcl_ObjPrintf(
"procedure \"%s\": formal parameter \"", procName);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" has "
"default value inconsistent with precompiled body", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", (char *)NULL);
goto procError;
}
}
if ((i == numArgs - 1)
&& (localPtr->nameLength == 4)
&& (localPtr->name[0] == 'a')
&& (strcmp(localPtr->name, "args") == 0)) {
|
| ︙ | ︙ | |||
841 842 843 844 845 846 847 |
}
}
badLevel:
if (name == NULL) {
name = objPtr ? TclGetString(objPtr) : "1" ;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
| | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
}
}
badLevel:
if (name == NULL) {
name = objPtr ? TclGetString(objPtr) : "1" ;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, (char *)NULL);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UplevelObjCmd --
|
| ︙ | ︙ | |||
920 921 922 923 924 925 926 |
*/
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
int status;
Tcl_Size llength;
| | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 |
*/
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
int status;
Tcl_Size llength;
status = TclListObjLength(interp, objv[1], &llength);
if (status == TCL_OK && llength > 1) {
/* the first argument can't interpreted as a level. Avoid
* generating a string representation of the script. */
result = TclGetFrame(interp, "1", &framePtr);
if (result == -1) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 |
for (i=1 ; i<=numArgs ; i++, defPtr++) {
Tcl_Obj *argObj;
Tcl_Obj *namePtr = localName(framePtr, i-1);
if (defPtr->value.objPtr != NULL) {
TclNewObj(argObj);
| | > | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
for (i=1 ; i<=numArgs ; i++, defPtr++) {
Tcl_Obj *argObj;
Tcl_Obj *namePtr = localName(framePtr, i-1);
if (defPtr->value.objPtr != NULL) {
TclNewObj(argObj);
Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?",
(char *)NULL);
} else if (defPtr->flags & VAR_IS_ARGS) {
numArgs--;
final = "?arg ...?";
break;
} else {
argObj = namePtr;
Tcl_IncrRefCount(namePtr);
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 | * are being referenced at runtime. * *---------------------------------------------------------------------- */ static int InitArgsAndLocals( | | | 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 |
* are being referenced at runtime.
*
*----------------------------------------------------------------------
*/
static int
InitArgsAndLocals(
Tcl_Interp *interp, /* Interpreter in which procedure was
* invoked. */
int skip) /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
Proc *procPtr = framePtr->procPtr;
ByteCode *codePtr;
|
| ︙ | ︙ | |||
1500 1501 1502 1503 1504 1505 1506 | * to be popped by the caller. * *---------------------------------------------------------------------- */ int TclPushProcCallFrame( | | | | 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
* to be popped by the caller.
*
*----------------------------------------------------------------------
*/
int
TclPushProcCallFrame(
void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp, /* Interpreter in which procedure was
* invoked. */
Tcl_Size objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[], /* Argument value objects. */
int isLambda) /* 1 if this is a call by ApplyObjCmd: it
* needs special rules for error msg */
{
|
| ︙ | ︙ | |||
1542 1543 1544 1545 1546 1547 1548 | * Ensure the ByteCode's procPtr is the same (or it's precompiled). */ if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch) | | < | 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 |
* Ensure the ByteCode's procPtr is the same (or it's precompiled).
*/
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
|| ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes)) {
goto doCompilation;
}
} else {
doCompilation:
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
(isLambda ? "body of lambda term" : "body of proc"),
TclGetString(objv[isLambda]));
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 | * Depends on the commands in the procedure. * *---------------------------------------------------------------------- */ int TclObjInterpProc( | | | | | | | | | 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 |
* Depends on the commands in the procedure.
*
*----------------------------------------------------------------------
*/
int
TclObjInterpProc(
void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp, /* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
/*
* Not used much in the core; external interface for iTcl
*/
return Tcl_NRCallObjProc(interp, NRInterpProc, clientData, objc, objv);
}
int
TclNRInterpProc(
void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp, /* Interpreter in which procedure was
* invoked. */
Tcl_Size objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
int result = TclPushProcCallFrame(clientData, interp, objc, objv,
/*isLambda*/ 0);
if (result != TCL_OK) {
return TCL_ERROR;
}
return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}
static int
NRInterpProc(
void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp, /* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
int result = TclPushProcCallFrame(clientData, interp, objc, objv,
/*isLambda*/ 0);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 |
{
/*
* Not used much in the core; external interface for iTcl
*/
return Tcl_NRCallObjProc2(interp, TclNRInterpProc, clientData, objc, objv);
}
| < | 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 |
{
/*
* Not used much in the core; external interface for iTcl
*/
return Tcl_NRCallObjProc2(interp, TclNRInterpProc, clientData, objc, objv);
}
/*
*----------------------------------------------------------------------
*
* TclNRInterpProcCore --
*
* When a Tcl procedure, lambda term or anything else that works like a
|
| ︙ | ︙ | |||
1686 1687 1688 1689 1690 1691 1692 | * Nearly anything; depends on the commands in the procedure body. * *---------------------------------------------------------------------- */ int TclNRInterpProcCore( | | | | 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 |
* Nearly anything; depends on the commands in the procedure body.
*
*----------------------------------------------------------------------
*/
int
TclNRInterpProcCore(
Tcl_Interp *interp, /* Interpreter in which procedure was
* invoked. */
Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
Tcl_Size skip, /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
ProcErrorProc *errorProc) /* How to convert results from the script into
* results of the overall procedure. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
int result;
|
| ︙ | ︙ | |||
1856 1857 1858 1859 1860 1861 1862 | * It's an error to get to this point from a 'break' or 'continue', so * transform to an error now. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); | | | 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 |
* It's an error to get to this point from a 'break' or 'continue', so
* transform to an error now.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invoked \"%s\" outside of a loop",
((result == TCL_BREAK) ? "break" : "continue")));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (char *)NULL);
result = TCL_ERROR;
/* FALLTHRU */
case TCL_ERROR:
/*
* Now it _must_ be an error, so we need to log it as such. This means
|
| ︙ | ︙ | |||
1930 1931 1932 1933 1934 1935 1936 |
*/
if (codePtr != NULL) {
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
&& (codePtr->nsEpoch == nsPtr->resolverEpoch)
| | < | | 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
*/
if (codePtr != NULL) {
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
&& (codePtr->nsEpoch == nsPtr->resolverEpoch)
&& ((codePtr->procPtr == procPtr) || !bodyPtr->bytes)) {
return TCL_OK;
}
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"a precompiled script jumped interps", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"CROSSINTERPBYTECODE", (char *)NULL);
return TCL_ERROR;
}
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
Tcl_StoreInternalRep(bodyPtr, &tclByteCodeType, NULL);
codePtr = NULL;
|
| ︙ | ︙ | |||
1965 1966 1967 1968 1969 1970 1971 | * to compile. */ Tcl_Obj *message; TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); | | | 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 |
* to compile.
*/
Tcl_Obj *message;
TclNewLiteralStringObj(message, "Compiling ");
Tcl_IncrRefCount(message);
Tcl_AppendStringsToObj(message, description, " \"", (char *)NULL);
Tcl_AppendLimitedToObj(message, procName, TCL_INDEX_NONE, 50, NULL);
fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
}
#else
(void)description;
(void)procName;
|
| ︙ | ︙ | |||
2027 2028 2029 2030 2031 2032 2033 | /* isProcCallFrame */ 0); /* * TIP #280: We get the invoking context from the cmdFrame which * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). */ | | | 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 | /* isProcCallFrame */ 0); /* * TIP #280: We get the invoking context from the cmdFrame which * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). */ hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, procPtr); /* * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. */ iPtr->invokeWord = 0; iPtr->invokeCmdFramePtr = hePtr ? (CmdFrame *)Tcl_GetHashValue(hePtr) : NULL; |
| ︙ | ︙ | |||
2077 2078 2079 2080 2081 2082 2083 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
| | | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > (Tcl_Size)limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %d)",
(overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
|
| ︙ | ︙ | |||
2108 2109 2110 2111 2112 2113 2114 | * procedure completes. * *---------------------------------------------------------------------- */ void TclProcDeleteProc( | | | 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 |
* procedure completes.
*
*----------------------------------------------------------------------
*/
void
TclProcDeleteProc(
void *clientData) /* Procedure to be deleted. */
{
Proc *procPtr = (Proc *)clientData;
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
}
|
| ︙ | ︙ | |||
2136 2137 2138 2139 2140 2141 2142 | * Memory gets freed. * *---------------------------------------------------------------------- */ void TclProcCleanupProc( | | | 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 |
* Memory gets freed.
*
*----------------------------------------------------------------------
*/
void
TclProcCleanupProc(
Proc *procPtr) /* Procedure to be deleted. */
{
CompiledLocal *localPtr;
Tcl_Obj *bodyPtr = procPtr->bodyPtr;
Tcl_Obj *defPtr;
Tcl_ResolvedVarInfo *resVarInfo;
Tcl_HashEntry *hePtr = NULL;
CmdFrame *cfPtr = NULL;
|
| ︙ | ︙ | |||
2187 2188 2189 2190 2191 2192 2193 |
* procbody structures created by tbcload.
*/
if (iPtr == NULL) {
return;
}
| | | 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 |
* procbody structures created by tbcload.
*/
if (iPtr == NULL) {
return;
}
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, procPtr);
if (!hePtr) {
return;
}
cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
if (cfPtr) {
|
| ︙ | ︙ | |||
2391 2392 2393 2394 2395 2396 2397 | /* *---------------------------------------------------------------------- * * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny -- * * How to manage the internal representations of lambda term objects. * Syntactically they look like a two- or three-element list, where the | | | | | | | | | | 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 |
/*
*----------------------------------------------------------------------
*
* DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny --
*
* How to manage the internal representations of lambda term objects.
* Syntactically they look like a two- or three-element list, where the
* first element is the formal arguments, the second is the body, and
* the (optional) third is the namespace to execute the lambda term
* within (the global namespace is assumed if it is absent).
*
*----------------------------------------------------------------------
*/
static void
DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetInternalRep(srcPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
procPtr->refCount++;
LambdaSetInternalRep(copyPtr, procPtr, nsObjPtr);
}
static void
FreeLambdaInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
}
static int
SetLambdaFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
int isNew, result;
Tcl_Size objc;
CmdFrame *cfPtr = NULL;
Proc *procPtr;
if (interp == NULL) {
return TCL_ERROR;
}
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
* length is not 2, then it cannot be converted to lambdaType.
*/
result = TclListObjLength(NULL, objPtr, &objc);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
Tcl_GetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (char *)NULL);
return TCL_ERROR;
}
result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (char *)NULL);
return TCL_ERROR;
}
argsPtr = objv[0];
bodyPtr = objv[1];
/*
|
| ︙ | ︙ | |||
2591 2592 2593 2594 2595 2596 2597 |
*/
if (objc == 2) {
TclNewLiteralStringObj(nsObjPtr, "::");
} else {
const char *nsName = TclGetString(objv[2]);
| | | 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 |
*/
if (objc == 2) {
TclNewLiteralStringObj(nsObjPtr, "::");
} else {
const char *nsName = TclGetString(objv[2]);
if ((nsName[0] != ':') || (nsName[1] != ':')) {
TclNewLiteralStringObj(nsObjPtr, "::");
Tcl_AppendObjToObj(nsObjPtr, objv[2]);
} else {
nsObjPtr = objv[2];
}
}
|
| ︙ | ︙ | |||
2620 2621 2622 2623 2624 2625 2626 |
Tcl_Obj **nsObjPtrPtr)
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
| | | 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 |
Tcl_Obj **nsObjPtrPtr)
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
if (!procPtr || (procPtr->iPtr != (Interp *)interp)) {
if (SetLambdaFromAny(interp, objPtr) != TCL_OK) {
return NULL;
}
LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
}
assert(procPtr != NULL);
|
| ︙ | ︙ | |||
2771 2772 2773 2774 2775 2776 2777 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
| | | 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > (Tcl_Size)limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (lambda term \"%.*s%s\" line %d)",
(overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
typedef struct ProcessInfo {
Tcl_Pid pid; /* Process id. */
int resolvedPid; /* Resolved process id. */
int purge; /* Purge eventualy. */
TclProcessWaitStatus status;/* Process status. */
int code; /* Error code, exit status or signal
| | > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
typedef struct ProcessInfo {
Tcl_Pid pid; /* Process id. */
int resolvedPid; /* Resolved process id. */
int purge; /* Purge eventualy. */
TclProcessWaitStatus status;/* Process status. */
int code; /* Error code, exit status or signal
* number. */
Tcl_Obj *msg; /* Error message. */
Tcl_Obj *error; /* Error code. */
} ProcessInfo;
static Tcl_HashTable infoTablePerPid;
static Tcl_HashTable infoTablePerResolvedPid;
static int infoTablesInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(infoTablesMutex)
/*
* Prototypes for functions defined later in this file:
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
*----------------------------------------------------------------------
*/
void
InitProcessInfo(
ProcessInfo *info, /* Structure to initialize. */
Tcl_Pid pid, /* Process id. */
| | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
*----------------------------------------------------------------------
*/
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;
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
*
*----------------------------------------------------------------------
*/
int
RefreshProcessInfo(
ProcessInfo *info, /* Structure to refresh. */
| | < > | > | > > | 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 |
*
*----------------------------------------------------------------------
*/
int
RefreshProcessInfo(
ProcessInfo *info, /* Structure to refresh. */
int options) /* Options passed to WaitProcessStatus. */
{
if (info->status == TCL_PROCESS_UNCHANGED) {
/*
* Refresh & store status.
*/
info->status = WaitProcessStatus(info->pid, info->resolvedPid,
options, &info->code, &info->msg, &info->error);
if (info->msg) {
Tcl_IncrRefCount(info->msg);
}
if (info->error) {
Tcl_IncrRefCount(info->error);
}
return (info->status != TCL_PROCESS_UNCHANGED);
} else {
/*
* No change.
*/
return 0;
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
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.
| | < | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
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. */
Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
{
int waitStatus;
Tcl_Obj *errorStrings[5];
const char *msg;
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 | * This changeup in message suggested by Mark Diekhans to * remind people that ECHILD errors can occur on some * systems if SIGCHLD isn't in its default state. */ msg = "child process lost (is SIGCHLD ignored or trapped?)"; } | | > > > | | > > | > | > > | > > > | | > > | > | | > > | > | | > | > > > | | > < | 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 |
* This changeup in message suggested by Mark Diekhans to
* remind people that ECHILD errors can occur on some
* systems if SIGCHLD isn't in its default state.
*/
msg = "child process lost (is SIGCHLD ignored or trapped?)";
}
if (codePtr) {
*codePtr = errno;
}
if (msgObjPtr) {
*msgObjPtr = Tcl_ObjPrintf(
"error waiting for process to exit: %s", msg);
}
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
errorStrings[2] = Tcl_NewStringObj(msg, -1);
*errorObjPtr = Tcl_NewListObj(3, errorStrings);
}
return TCL_PROCESS_ERROR;
} else if (WIFEXITED(waitStatus)) {
if (codePtr) {
*codePtr = WEXITSTATUS(waitStatus);
}
if (!WEXITSTATUS(waitStatus)) {
/*
* Normal exit.
*/
if (msgObjPtr) {
*msgObjPtr = NULL;
}
if (errorObjPtr) {
*errorObjPtr = NULL;
}
} else {
/*
* CHILDSTATUS pid code
*
* Child exited with a non-zero exit status.
*/
if (msgObjPtr) {
*msgObjPtr = Tcl_NewStringObj(
"child process exited abnormally", -1);
}
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
TclNewIntObj(errorStrings[1], resolvedPid);
TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus));
*errorObjPtr = Tcl_NewListObj(3, errorStrings);
}
}
return TCL_PROCESS_EXITED;
} else if (WIFSIGNALED(waitStatus)) {
/*
* CHILDKILLED pid sigName msg
*
* Child killed because of a signal.
*/
msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
if (codePtr) {
*codePtr = WTERMSIG(waitStatus);
}
if (msgObjPtr) {
*msgObjPtr = Tcl_ObjPrintf("child killed: %s", msg);
}
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
TclNewIntObj(errorStrings[1], resolvedPid);
errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
errorStrings[3] = Tcl_NewStringObj(msg, -1);
*errorObjPtr = Tcl_NewListObj(4, errorStrings);
}
return TCL_PROCESS_SIGNALED;
} else if (WIFSTOPPED(waitStatus)) {
/*
* CHILDSUSP pid sigName msg
*
* Child suspended because of a signal.
*/
msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
if (codePtr) {
*codePtr = WSTOPSIG(waitStatus);
}
if (msgObjPtr) {
*msgObjPtr = Tcl_ObjPrintf("child suspended: %s", msg);
}
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
TclNewIntObj(errorStrings[1], resolvedPid);
errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
errorStrings[3] = Tcl_NewStringObj(msg, -1);
*errorObjPtr = Tcl_NewListObj(4, errorStrings);
}
return TCL_PROCESS_STOPPED;
} else {
/*
* TCL OPERATION EXEC ODDWAITRESULT
*
* Child wait status didn't make sense.
*/
if (codePtr) {
*codePtr = waitStatus;
}
if (msgObjPtr) {
*msgObjPtr = Tcl_NewStringObj(
"child wait status didn't make sense\n", -1);
}
if (errorObjPtr) {
errorStrings[0] = Tcl_NewStringObj("TCL", -1);
errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
TclNewIntObj(errorStrings[4], resolvedPid);
*errorObjPtr = Tcl_NewListObj(5, errorStrings);
}
return TCL_PROCESS_UNKNOWN_STATUS;
}
}
/*
*----------------------------------------------------------------------
*
* BuildProcessStatusObj --
*
* Build a list object with process status. The first element is always
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
| | | | 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 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
Tcl_DictObjPut(NULL, dict, Tcl_NewIntObj(info->resolvedPid),
BuildProcessStatusObj(info));
}
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Only return statuses of provided processes.
*/
result = TclListObjGetElements(interp, objv[1], &numPids, &pidObjs);
if (result != TCL_OK) {
return result;
}
dict = Tcl_NewDictObj();
Tcl_MutexLock(&infoTablesMutex);
for (i = 0; i < numPids; i++) {
result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
| | | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
Tcl_DictObjPut(NULL, dict, Tcl_NewIntObj(info->resolvedPid),
BuildProcessStatusObj(info));
}
}
Tcl_MutexUnlock(&infoTablesMutex);
}
Tcl_SetObjResult(interp, dict);
return TCL_OK;
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Purge only provided processes.
*/
| | | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 |
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Purge only provided processes.
*/
result = TclListObjGetElements(interp, objv[1], &numPids, &pidObjs);
if (result != TCL_OK) {
return result;
}
Tcl_MutexLock(&infoTablesMutex);
for (i = 0; i < numPids; i++) {
result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 | /* * Pid was reused, free old info and reuse structure. */ info = (ProcessInfo *) Tcl_GetHashValue(entry); entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid)); | > | > | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 |
/*
* Pid was reused, free old info and reuse structure.
*/
info = (ProcessInfo *) Tcl_GetHashValue(entry);
entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid,
INT2PTR(resolvedPid));
if (entry2) {
Tcl_DeleteHashEntry(entry2);
}
FreeProcessInfo(info);
}
/*
* Allocate and initialize info structure.
*/
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 |
Tcl_Pid pid, /* Process id. */
int options, /* Options passed to WaitProcessStatus. */
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.
| | < | > > | > > | < > < > | > > | > > | > > | > > | > > | 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 |
Tcl_Pid pid, /* Process id. */
int options, /* Options passed to WaitProcessStatus. */
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. */
Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
{
Tcl_HashEntry *entry;
ProcessInfo *info;
TclProcessWaitStatus result;
/*
* First search for pid in table.
*/
Tcl_MutexLock(&infoTablesMutex);
entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
if (!entry) {
/*
* Unknown process, just call WaitProcessStatus and return.
*/
result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr,
msgObjPtr, errorObjPtr);
if (msgObjPtr && *msgObjPtr) {
Tcl_IncrRefCount(*msgObjPtr);
}
if (errorObjPtr && *errorObjPtr) {
Tcl_IncrRefCount(*errorObjPtr);
}
Tcl_MutexUnlock(&infoTablesMutex);
return result;
}
info = (ProcessInfo *) Tcl_GetHashValue(entry);
if (info->purge) {
/*
* Process has completed but TclProcessWait has already been called,
* so report no change.
*/
Tcl_MutexUnlock(&infoTablesMutex);
return TCL_PROCESS_UNCHANGED;
}
RefreshProcessInfo(info, options);
if (info->status == TCL_PROCESS_UNCHANGED) {
/*
* No change, stop there.
*/
Tcl_MutexUnlock(&infoTablesMutex);
return TCL_PROCESS_UNCHANGED;
}
/*
* Set return values.
*/
result = info->status;
if (codePtr) {
*codePtr = info->code;
}
if (msgObjPtr) {
*msgObjPtr = info->msg;
}
if (errorObjPtr) {
*errorObjPtr = info->error;
}
if (msgObjPtr && *msgObjPtr) {
Tcl_IncrRefCount(*msgObjPtr);
}
if (errorObjPtr && *errorObjPtr) {
Tcl_IncrRefCount(*errorObjPtr);
}
if (autopurge) {
/*
* Purge now.
*/
Tcl_DeleteHashEntry(entry);
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 |
*/
info->purge = 1;
}
Tcl_MutexUnlock(&infoTablesMutex);
return result;
}
| > > > > > > > > | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 |
*/
info->purge = 1;
}
Tcl_MutexUnlock(&infoTablesMutex);
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclRegexp.c.
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
/*
* The regular expression Tcl object type. This serves as a cache of the
* compiled form of the regular expression.
*/
const Tcl_ObjType tclRegexpType = {
| | | | | | | | | | | < | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
/*
* The regular expression Tcl object type. This serves as a cache of the
* compiled form of the regular expression.
*/
const Tcl_ObjType tclRegexpType = {
"regexp", /* name */
FreeRegexpInternalRep, /* freeIntRepProc */
DupRegexpInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetRegexpFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define RegexpSetInternalRep(objPtr, rePtr) \
do { \
Tcl_ObjInternalRep ir; \
(rePtr)->refCount++; \
ir.twoPtrValue.ptr1 = (rePtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &tclRegexpType, &ir); \
} while (0)
#define RegexpGetInternalRep(objPtr, rePtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &tclRegexpType); \
(rePtr) = irPtr ? (TclRegexp *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpCompile --
*
* Compile a regular expression into a form suitable for fast matching.
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
/*
* Convert the string to Unicode and perform the match.
*/
Tcl_DStringInit(&ds);
ustr = Tcl_UtfToUniCharDString(text, TCL_INDEX_NONE, &ds);
numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
| | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
/*
* Convert the string to Unicode and perform the match.
*/
Tcl_DStringInit(&ds);
ustr = Tcl_UtfToUniCharDString(text, TCL_INDEX_NONE, &ds);
numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
result = RegExpExecUniChar(interp, re, ustr, numChars,
TCL_INDEX_NONE /* nmatches */, flags);
Tcl_DStringFree(&ds);
return result;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
static int
RegExpExecUniChar(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; returned by a
* previous call to Tcl_GetRegExpFromObj */
const Tcl_UniChar *wString, /* String against which to match re. */
size_t numChars, /* Length of Tcl_UniChar string. */
| | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
static int
RegExpExecUniChar(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; returned by a
* previous call to Tcl_GetRegExpFromObj */
const Tcl_UniChar *wString, /* String against which to match re. */
size_t numChars, /* Length of Tcl_UniChar string. */
size_t nm, /* How many subexpression matches (counting
* the whole match as subexpression 0) are of
* interest. -1 means "don't know". */
int flags) /* Regular expression flags. */
{
int status;
TclRegexp *regexpPtr = (TclRegexp *) re;
size_t last = regexpPtr->re.re_nsub + 1;
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
TclRegExpRangeUniChar(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
Tcl_Size index, /* 0 means give the range of the entire match,
* > 0 means give the range of a matching
* subrange, -1 means the range of the
* rm_extend field. */
| | | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
TclRegExpRangeUniChar(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
Tcl_Size index, /* 0 means give the range of the entire match,
* > 0 means give the range of a matching
* subrange, -1 means the range of the
* rm_extend field. */
Tcl_Size *startPtr, /* Store address of first character in
* (sub-)range here. */
Tcl_Size *endPtr) /* Store address of character just after last
* in (sub-)range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
if ((regexpPtr->flags®_EXPECT) && (index == -1)) {
*startPtr = regexpPtr->details.rm_extend.rm_so;
*endPtr = regexpPtr->details.rm_extend.rm_eo;
|
| ︙ | ︙ | |||
441 442 443 444 445 446 447 |
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; must have been
* returned by previous call to
* Tcl_GetRegExpFromObj. */
Tcl_Obj *textObj, /* Text against which to match re. */
Tcl_Size offset, /* Character index that marks where matching
* should begin. */
| | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; must have been
* returned by previous call to
* Tcl_GetRegExpFromObj. */
Tcl_Obj *textObj, /* Text against which to match re. */
Tcl_Size offset, /* Character index that marks where matching
* should begin. */
Tcl_Size nmatches, /* How many subexpression matches (counting
* the whole match as subexpression 0) are of
* interest. -1 means all of them. */
int flags) /* Regular expression execution flags. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
Tcl_UniChar *udata;
Tcl_Size length;
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
* For performance reasons, first try compiling the RE without support for
* subexpressions. On failure, try again without TCL_REG_NOSUB in case the
* RE has backreferences in it. Closely related to [Bug 1366683]. If this
* still fails, an error message will be left in the interpreter.
*/
if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
| | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
* For performance reasons, first try compiling the RE without support for
* subexpressions. On failure, try again without TCL_REG_NOSUB in case the
* RE has backreferences in it. Closely related to [Bug 1366683]. If this
* still fails, an error message will be left in the interpreter.
*/
if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
TCL_REG_ADVANCED | TCL_REG_NOSUB)) &&
!(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) {
return -1;
}
return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
0 /* nmatches */, 0 /* flags */);
}
/*
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
Tcl_Size length;
TclRegexp *regexpPtr;
const char *pattern;
RegexpGetInternalRep(objPtr, regexpPtr);
if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
| | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
Tcl_Size length;
TclRegexp *regexpPtr;
const char *pattern;
RegexpGetInternalRep(objPtr, regexpPtr);
if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
return NULL;
}
RegexpSetInternalRep(objPtr, regexpPtr);
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 |
Tcl_ResetResult(interp);
n = TclReError(status, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p));
snprintf(cbuf, sizeof(cbuf), "%d", status);
(void) TclReError(REG_ITOA, cbuf, sizeof(cbuf));
| | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
Tcl_ResetResult(interp);
n = TclReError(status, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p));
snprintf(cbuf, sizeof(cbuf), "%d", status);
(void) TclReError(REG_ITOA, cbuf, sizeof(cbuf));
Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, (char *)NULL);
}
/*
*----------------------------------------------------------------------
*
* FreeRegexpInternalRep --
*
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 |
*----------------------------------------------------------------------
*/
static TclRegexp *
CompileRegexp(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *string, /* The regexp to compile (UTF-8). */
| | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
*----------------------------------------------------------------------
*/
static TclRegexp *
CompileRegexp(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *string, /* The regexp to compile (UTF-8). */
size_t length, /* The length of the string in bytes. */
int flags) /* Compilation flags. */
{
TclRegexp *regexpPtr;
const Tcl_UniChar *uniString;
int numChars, status, i, exact;
Tcl_DString stringBuf;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
943 944 945 946 947 948 949 |
/*
* Clean up and report errors in the interpreter, if possible.
*/
Tcl_Free(regexpPtr);
if (interp) {
TclRegError(interp,
| | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
/*
* Clean up and report errors in the interpreter, if possible.
*/
Tcl_Free(regexpPtr);
if (interp) {
TclRegError(interp,
"cannot compile regular expression pattern: ", status);
}
return NULL;
}
/*
* Convert RE to a glob pattern equivalent, if any, and cache it. If this
* is not possible, then globObjPtr will be NULL. This is used by
|
| ︙ | ︙ |
Changes to generic/tclRegexp.h.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 |
Tcl_Obj *globObjPtr; /* Glob pattern rep of RE or NULL if none. */
regmatch_t *matches; /* Array of indices into the Tcl_UniChar
* representation of the last string matched
* with this regexp to indicate the location
* of subexpressions. */
rm_detail_t details; /* Detailed information on match (currently
* used only for REG_EXPECT). */
| | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
Tcl_Obj *globObjPtr; /* Glob pattern rep of RE or NULL if none. */
regmatch_t *matches; /* Array of indices into the Tcl_UniChar
* representation of the last string matched
* with this regexp to indicate the location
* of subexpressions. */
rm_detail_t details; /* Detailed information on match (currently
* used only for REG_EXPECT). */
Tcl_Size refCount; /* Count of number of references to this
* compiled regexp. */
} TclRegexp;
#endif /* _TCLREGEXP */
/*
* Local Variables:
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | /* *---------------------------------------------------------------------- * * Tcl_SaveInterpState -- * * Fills a token with a snapshot of the current state of the interpreter. | | | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | /* *---------------------------------------------------------------------- * * Tcl_SaveInterpState -- * * Fills a token with a snapshot of the current state of the interpreter. * The snapshot can be restored at any point by Tcl_RestoreInterpState. * * The token returned must be eventually passed to one of the routines * Tcl_RestoreInterpState or Tcl_DiscardInterpState, or there will be a * memory leak. * * Results: * Returns a token representing the interp state. * * Side effects: * None. |
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
const char *bytes;
Tcl_Size length;
if (Tcl_IsShared(iPtr->objResultPtr)) {
Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
}
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
const char *bytes;
Tcl_Size length;
if (Tcl_IsShared(iPtr->objResultPtr)) {
Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
}
bytes = TclGetStringFromObj(iPtr->objResultPtr, &length);
if (TclNeedSpace(bytes, bytes + length)) {
Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
}
Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
Tcl_DecrRefCount(listPtr);
}
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 | * It also clears any error information for the interpreter. * *---------------------------------------------------------------------- */ void Tcl_ResetResult( | | | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
* It also clears any error information for the interpreter.
*
*----------------------------------------------------------------------
*/
void
Tcl_ResetResult(
Tcl_Interp *interp) /* Interpreter for which to clear result. */
{
Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 | * the interpreter. * *---------------------------------------------------------------------- */ static void ResetObjResult( | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
* the interpreter.
*
*----------------------------------------------------------------------
*/
static void
ResetObjResult(
Interp *iPtr) /* Points to the interpreter whose result
* object should be reset. */
{
Tcl_Obj *objResultPtr = iPtr->objResultPtr;
if (Tcl_IsShared(objResultPtr)) {
TclDecrRefCount(objResultPtr);
TclNewObj(objResultPtr);
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
if (code == TCL_ERROR) {
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
if (code == TCL_ERROR) {
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
Tcl_Size length;
(void)TclGetStringFromObj(valuePtr, &length);
if (length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
&valuePtr);
if (valuePtr != NULL) {
Tcl_Size len, valueObjc;
Tcl_Obj **valueObjv;
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
/*
* List extraction done after duplication to avoid moving the rug
* if someone does [return -errorstack [info errorstack]]
*/
if (TclListObjGetElements(interp, valuePtr, &valueObjc,
&valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
TclListObjLength(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
valueObjv);
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
&valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
} else {
Tcl_SetErrorCode(interp, "NONE", (char *)NULL);
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
&valuePtr);
if (valuePtr != NULL) {
TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
}
if (level != 0) {
iPtr->returnLevel = level;
iPtr->returnCode = code;
|
| ︙ | ︙ | |||
839 840 841 842 843 844 845 |
if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search,
&keyPtr, &valuePtr, &done)) {
/*
* Value is not a legal dictionary.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search,
&keyPtr, &valuePtr, &done)) {
/*
* Value is not a legal dictionary.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad %s value: expected dictionary but got \"%s\"",
compare, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
(char *)NULL);
goto error;
}
while (!done) {
Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
/*
* Check for bogus -code value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if (valuePtr != NULL) {
if (TclGetCompletionCodeFromObj(interp, valuePtr,
| | | | | | | | | | | | | | | | | | | | | 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 |
/*
* Check for bogus -code value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if (valuePtr != NULL) {
if (TclGetCompletionCodeFromObj(interp, valuePtr,
&code) == TCL_ERROR) {
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
}
/*
* Check for bogus -level value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
if (valuePtr != NULL) {
if ((TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &level))
|| (level < 0)) {
/*
* Value is not a legal level.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -level value: expected non-negative integer but got"
" \"%s\"", TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (char *)NULL);
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
}
/*
* Check for bogus -errorcode value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
if (valuePtr != NULL) {
Tcl_Size length;
if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorcode.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorcode value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
(char *)NULL);
goto error;
}
}
/*
* Check for bogus -errorstack value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
if (valuePtr != NULL) {
Tcl_Size length;
if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length)) {
/*
* Value is not a list, which is illegal for -errorstack.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorstack value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
(char *)NULL);
goto error;
}
if (length % 2) {
/*
* Errorstack must always be an even-sized list
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"forbidden odd-sized list for -errorstack: \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT",
"ODDSIZEDLIST_ERRORSTACK", (char *)NULL);
goto error;
}
}
/*
* Convert [return -code return -level X] to [return -code ok -level X+1]
*/
if (code == TCL_RETURN) {
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 |
Tcl_NewWideIntObj(result));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
Tcl_NewWideIntObj(0));
}
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "");
| | | 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 |
Tcl_NewWideIntObj(result));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
Tcl_NewWideIntObj(0));
}
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "");
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
}
if (iPtr->errorCode) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
}
if (iPtr->errorInfo) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
|
| ︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 |
Tcl_Obj *options)
{
Tcl_Size objc;
int level, code;
Tcl_Obj **objv, *mergedOpts;
Tcl_IncrRefCount(options);
| | | | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 |
Tcl_Obj *options)
{
Tcl_Size objc;
int level, code;
Tcl_Obj **objv, *mergedOpts;
Tcl_IncrRefCount(options);
if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected dict but got \"%s\"", TclGetString(options)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (char *)NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
&mergedOpts, &code, &level)) {
code = TCL_ERROR;
} else {
code = TclProcessReturn(interp, code, level, mergedOpts);
}
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | #include "tclInt.h" #include "tclTomMath.h" #include <assert.h> /* * Flag values used by Tcl_ScanObjCmd. */ | | | | | | | | > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
#include "tclInt.h"
#include "tclTomMath.h"
#include <assert.h>
/*
* Flag values used by Tcl_ScanObjCmd.
*/
enum ScanFlags {
SCAN_NOSKIP = 0x1, /* Don't skip blanks. */
SCAN_SUPPRESS = 0x2, /* Suppress assignment. */
SCAN_UNSIGNED = 0x4, /* Read an unsigned value. */
SCAN_WIDTH = 0x8, /* A width value was supplied. */
SCAN_LONGER = 0x400, /* Asked for a wide value. */
SCAN_BIG = 0x800 /* Asked for a bignum value. */
};
/*
* The following structure contains the information associated with a
* character set.
*/
typedef struct {
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 |
/* >=INT_MAX because 9.0 does not support more than INT_MAX-1 args */
if (ull == 0 || ull >= INT_MAX) {
goto badIndex;
}
objIndex = (int) ull - 1;
if (numVars && (objIndex >= numVars)) {
goto badIndex;
| < | | | | < | | < | | > > > > > > > > > > > | > | | | 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 |
/* >=INT_MAX because 9.0 does not support more than INT_MAX-1 args */
if (ull == 0 || ull >= INT_MAX) {
goto badIndex;
}
objIndex = (int) ull - 1;
if (numVars && (objIndex >= numVars)) {
goto badIndex;
} else if (numVars == 0) {
/*
* In the case where no vars are specified, the user can
* specify %9999$ legally, so we have to consider special
* rules for growing the assign array. 'ull' is guaranteed
* to be > 0 and < INT_MAX as per checks above.
*/
xpgSize = (xpgSize > (int)ull) ? xpgSize : (int)ull;
}
goto xpgCheckDone;
}
notXpg:
gotSequential = 1;
if (gotXpg) {
mixedXPG:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot mix \"%\" and \"%n$\" conversion specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", (char *)NULL);
goto error;
}
xpgCheckDone:
/*
* Parse any width specifier.
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
/* Note ull >= 0 because of isdigit check above */
unsigned long long ull;
ull = strtoull(
format - 1, (char **)&format, 10); /* INTL: "C" locale. */
/* Note >=, not >, to leave room for a nul */
if (ull >= TCL_SIZE_MAX) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"specified field width %" TCL_LL_MODIFIER
"u exceeds limit %" TCL_SIZE_MODIFIER "d.",
ull, (Tcl_Size)TCL_SIZE_MAX-1));
Tcl_SetErrorCode(
interp, "TCL", "FORMAT", "WIDTHLIMIT", (char *)NULL);
goto error;
}
flags |= SCAN_WIDTH;
format += TclUtfToUniChar(format, &ch);
}
/*
* Handle any size specifier.
*/
switch (ch) {
case 'z':
case 't':
if (sizeof(void *) > sizeof(int)) {
flags |= SCAN_LONGER;
}
format += TclUtfToUniChar(format, &ch);
break;
case 'L':
flags |= SCAN_BIG;
format += TclUtfToUniChar(format, &ch);
break;
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
/* FALLTHRU */
case 'j':
case 'q':
flags |= SCAN_LONGER;
/* FALLTHRU */
case 'h':
format += TclUtfToUniChar(format, &ch);
}
if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
/*
* Handle the various field types.
*/
switch (ch) {
case 'c':
if (flags & SCAN_WIDTH) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", (char *)NULL);
goto error;
}
/* FALLTHRU */
case 'n':
case 's':
if (flags & (SCAN_LONGER|SCAN_BIG)) {
invalidFieldSize:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
errorMsg = Tcl_NewStringObj(
"field size modifier may not be specified in %", -1);
Tcl_AppendToObj(errorMsg, buf, -1);
Tcl_AppendToObj(errorMsg, " conversion", -1);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", (char *)NULL);
goto error;
}
/*
* Fall through!
*/
case 'd':
case 'e':
|
| ︙ | ︙ | |||
471 472 473 474 475 476 477 | } format += TclUtfToUniChar(format, &ch); } break; badSet: Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched [ in format string", -1)); | | | | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
}
format += TclUtfToUniChar(format, &ch);
}
break;
badSet:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched [ in format string", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", (char *)NULL);
goto error;
default:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
errorMsg = Tcl_NewStringObj(
"bad scan conversion character \"", -1);
Tcl_AppendToObj(errorMsg, buf, -1);
Tcl_AppendToObj(errorMsg, "\"", -1);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (char *)NULL);
goto error;
}
if (!(flags & SCAN_SUPPRESS)) {
if (objIndex >= nspace) {
/*
* Expand the nassign buffer. If we are using XPG specifiers,
* make sure that we grow to a large enough size. xpgSize is
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
*totalSubs = numVars;
}
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is assigned by multiple \"%n$\" conversion specifiers",
-1));
| | | | | | 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 |
*totalSubs = numVars;
}
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is assigned by multiple \"%n$\" conversion specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", (char *)NULL);
goto error;
} else if (!xpgSize && (nassign[i] == 0)) {
/*
* If the space is empty, and xpgSize is 0 (means XPG wasn't used,
* and/or numVars != 0), then too many vars were given
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is not assigned by any conversion specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", (char *)NULL);
goto error;
}
}
TclStackFree(interp, nassign);
return TCL_OK;
badIndex:
if (gotXpg) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"%n$\" argument index out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", (char *)NULL);
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"different numbers of variable names and field specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", (char *)NULL);
}
error:
TclStackFree(interp, nassign);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
| | | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
int value;
const char *string, *end, *baseString;
char op = 0;
int underflow = 0;
Tcl_Size width;
Tcl_WideInt wideValue;
Tcl_UniChar ch = 0, sch = 0;
Tcl_Obj **objs = NULL, *objPtr = NULL;
|
| ︙ | ︙ | |||
694 695 696 697 698 699 700 |
} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
char *formatEnd;
/* Note currently XPG3 range limited to INT_MAX to match type of objc */
value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
if (*formatEnd == '$') {
format = formatEnd+1;
format += TclUtfToUniChar(format, &ch);
| | | > > > > > > > > > > > | > | 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 |
} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
char *formatEnd;
/* Note currently XPG3 range limited to INT_MAX to match type of objc */
value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
if (*formatEnd == '$') {
format = formatEnd+1;
format += TclUtfToUniChar(format, &ch);
objIndex = (int)value - 1;
}
}
/*
* Parse any width specifier.
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
unsigned long long ull;
ull = strtoull(format-1, (char **)&format, 10); /* INTL: "C" locale. */
assert(ull <= TCL_SIZE_MAX); /* Else ValidateFormat should've error'ed */
width = (Tcl_Size)ull;
format += TclUtfToUniChar(format, &ch);
} else {
width = 0;
}
/*
* Handle any size specifier.
*/
switch (ch) {
case 'z':
case 't':
if (sizeof(void *) > sizeof(int)) {
flags |= SCAN_LONGER;
}
format += TclUtfToUniChar(format, &ch);
break;
case 'L':
flags |= SCAN_BIG;
format += TclUtfToUniChar(format, &ch);
break;
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
/* FALLTHRU */
case 'j':
case 'q':
flags |= SCAN_LONGER;
/* FALLTHRU */
case 'h':
format += TclUtfToUniChar(format, &ch);
}
/*
|
| ︙ | ︙ | |||
899 900 901 902 903 904 905 | break; } case 'c': /* * Scan a single Unicode character. */ | | | | 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 |
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
offset = TclUtfToUniChar(string, &i);
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
TclNewIntObj(objPtr, i);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
TclNewIntObj(objPtr, 0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
|
| ︙ | ︙ | |||
950 951 952 953 954 955 956 |
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
mp_int big;
if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create bignum", -1));
| | | 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 |
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
mp_int big;
if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create bignum", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
return TCL_ERROR;
} else {
Tcl_SetBignumObj(objPtr, &big);
}
} else {
TclSetIntObj(objPtr, wideValue);
}
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
if (objs != NULL) {
Tcl_Free(objs);
}
Tcl_DecrRefCount(objPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unsigned bignum scans are invalid", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT",
| | | | | | | 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 |
if (objs != NULL) {
Tcl_Free(objs);
}
Tcl_DecrRefCount(objPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unsigned bignum scans are invalid", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT",
"BADUNSIGNED", (char *)NULL);
return TCL_ERROR;
}
}
} else {
if (TclGetIntFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = INT_MIN;
} else {
value = INT_MAX;
}
}
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
mp_int big;
if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create bignum", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
return TCL_ERROR;
} else {
Tcl_SetBignumObj(objPtr, &big);
}
#else
Tcl_SetWideIntObj(objPtr, (unsigned long)value);
#endif
|
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 |
}
} else {
/*
* Here no vars were specified, we want a list returned (inline scan)
* We create an empty Tcl_Obj to fill missing values rather than
* allocating a new Tcl_Obj every time. See test scan-bigdata-XX.
*/
| | < < > > | < | 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 |
}
} else {
/*
* Here no vars were specified, we want a list returned (inline scan)
* We create an empty Tcl_Obj to fill missing values rather than
* allocating a new Tcl_Obj every time. See test scan-bigdata-XX.
*/
Tcl_Obj *emptyObj = NULL;
TclNewObj(objPtr);
for (i = 0; code == TCL_OK && i < totalVars; i++) {
if (objs[i] != NULL) {
code = Tcl_ListObjAppendElement(interp, objPtr, objs[i]);
Tcl_DecrRefCount(objs[i]);
} else {
/*
* More %-specifiers than matching chars, so we just spit out
* empty strings for these.
*/
if (!emptyObj) {
TclNewObj(emptyObj);
}
code = Tcl_ListObjAppendElement(interp, objPtr, emptyObj);
}
}
if (code != TCL_OK) {
/* If error'ed out, free up remaining. i contains last index freed */
while (++i < totalVars) {
if (objs[i] != NULL) {
Tcl_DecrRefCount(objs[i]);
}
}
|
| ︙ | ︙ |
Added generic/tclStrIdxTree.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 |
/*
* tclStrIdxTree.c --
*
* Contains the routines for managing string index tries in Tcl.
*
* This code is back-ported from the tclSE engine, by Serg G. Brester.
*
* Copyright (c) 2016 by Sergey G. Brester aka sebres. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* -----------------------------------------------------------------------
*
* String index tries are prepaired structures used for fast greedy search of the string
* (index) by unique string prefix as key.
*
* Index tree build for two lists together can be explained in the following datagram
*
* Lists:
*
* {Januar Februar Maerz April Mai Juni Juli August September Oktober November Dezember}
* {Jnr Fbr Mrz Apr Mai Jni Jli Agt Spt Okt Nvb Dzb}
*
* Index-Tree:
*
* j 0 * ...
* anuar 1 *
* u 0 * a 0
* ni 6 * pril 4
* li 7 * ugust 8
* n 0 * gt 8
* r 1 * s 9
* i 6 * eptember 9
* li 7 * pt 9
* f 2 * oktober 10
* ebruar 2 * n 11
* br 2 * ovember 11
* m 0 * vb 11
* a 0 * d 12
* erz 3 * ezember 12
* i 5 * zb 12
* rz 3 *
* ...
*
* Thereby value 0 shows pure group items (corresponding ambigous matches).
* But the group may have a value if it contains only same values
* (see for example group "f" above).
*
* StrIdxTree's are very fast, so:
* build of above-mentioned tree takes about 10 microseconds.
* search of string index in this tree takes fewer as 0.1 microseconds.
*
*/
#include "tclInt.h"
#include "tclStrIdxTree.h"
static void StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr);
static void StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr);
static const Tcl_ObjType StrIdxTreeObjType = {
"str-idx-tree", /* name */
StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */
StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */
StrIdxTreeObj_UpdateStringProc, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
/*
*----------------------------------------------------------------------
*
* TclStrIdxTreeSearch --
*
* Find largest part of string "start" in indexed tree (case sensitive).
*
* Also used for building of string index tree.
*
* Results:
* Return position of UTF character in start after last equal character
* and found item (with parent).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
const char *
TclStrIdxTreeSearch(
TclStrIdxTree **foundParent,/* Return value of found sub tree (used for tree build) */
TclStrIdx **foundItem, /* Return value of found item */
TclStrIdxTree *tree, /* Index tree will be browsed */
const char *start, /* UTF string to find in tree */
const char *end) /* End of string */
{
TclStrIdxTree *parent = tree, *prevParent = tree;
TclStrIdx *item = tree->firstPtr, *prevItem = NULL;
const char *s = start, *f, *cin, *cinf, *prevf = NULL;
Tcl_Size offs = 0;
if (item == NULL) {
goto done;
}
/* search in tree */
do {
cinf = cin = TclGetString(item->key) + offs;
f = TclUtfFindEqualNCInLwr(s, end, cin, cin + item->length - offs, &cinf);
/* if something was found */
if (f > s) {
/* if whole string was found */
if (f >= end) {
start = f;
goto done;
}
/* set new offset and shift start string */
offs += cinf - cin;
s = f;
/* if match item, go deeper as long as possible */
if (offs >= item->length && item->childTree.firstPtr) {
/* save previuosly found item (if not ambigous) for
* possible fallback (few greedy match) */
if (item->value != NULL) {
prevf = f;
prevItem = item;
prevParent = parent;
}
parent = &item->childTree;
item = item->childTree.firstPtr;
continue;
}
/* no children - return this item and current chars found */
start = f;
goto done;
}
item = item->nextPtr;
} while (item != NULL);
/* fallback (few greedy match) not ambigous (has a value) */
if (prevItem != NULL) {
item = prevItem;
parent = prevParent;
start = prevf;
}
done:
if (foundParent) {
*foundParent = parent;
}
if (foundItem) {
*foundItem = item;
}
return start;
}
void
TclStrIdxTreeFree(
TclStrIdx *tree)
{
while (tree != NULL) {
TclStrIdx *t = tree;
Tcl_DecrRefCount(tree->key);
if (tree->childTree.firstPtr != NULL) {
TclStrIdxTreeFree(tree->childTree.firstPtr);
}
tree = tree->nextPtr;
Tcl_Free(t);
}
}
/*
* Several bidirectional list primitives
*/
static inline void
TclStrIdxTreeInsertBranch(
TclStrIdxTree *parent,
TclStrIdx *item,
TclStrIdx *child)
{
if (parent->firstPtr == child) {
parent->firstPtr = item;
}
if (parent->lastPtr == child) {
parent->lastPtr = item;
}
if ((item->nextPtr = child->nextPtr) != NULL) {
item->nextPtr->prevPtr = item;
child->nextPtr = NULL;
}
if ((item->prevPtr = child->prevPtr) != NULL) {
item->prevPtr->nextPtr = item;
child->prevPtr = NULL;
}
item->childTree.firstPtr = child;
item->childTree.lastPtr = child;
}
static inline void
TclStrIdxTreeAppend(
TclStrIdxTree *parent,
TclStrIdx *item)
{
if (parent->lastPtr != NULL) {
parent->lastPtr->nextPtr = item;
}
item->prevPtr = parent->lastPtr;
item->nextPtr = NULL;
parent->lastPtr = item;
if (parent->firstPtr == NULL) {
parent->firstPtr = item;
}
}
/*
*----------------------------------------------------------------------
*
* TclStrIdxTreeBuildFromList --
*
* Build or extend string indexed tree from tcl list. If the values not
* given the values of built list are indices starts with 1. Value of 0
* is thereby reserved to the ambigous values.
*
* Important: by multiple lists, optimal tree can be created only if list
* with larger strings used firstly.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclStrIdxTreeBuildFromList(
TclStrIdxTree *idxTree,
Tcl_Size lstc,
Tcl_Obj **lstv,
void **values)
{
Tcl_Obj **lwrv;
Tcl_Size i;
int ret = TCL_ERROR;
void *val;
const char *s, *e, *f;
TclStrIdx *item;
/* create lowercase reflection of the list keys */
lwrv = (Tcl_Obj **) Tcl_AttemptAlloc(sizeof(Tcl_Obj*) * lstc);
if (lwrv == NULL) {
return TCL_ERROR;
}
for (i = 0; i < lstc; i++) {
lwrv[i] = Tcl_DuplicateObj(lstv[i]);
Tcl_IncrRefCount(lwrv[i]);
lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i]));
}
/* build index tree of the list keys */
for (i = 0; i < lstc; i++) {
TclStrIdxTree *foundParent = idxTree;
e = s = TclGetString(lwrv[i]);
e += lwrv[i]->length;
val = values ? values[i] : INT2PTR(i+1);
/* ignore empty keys (impossible to index it) */
if (lwrv[i]->length == 0) {
continue;
}
item = NULL;
if (idxTree->firstPtr != NULL) {
TclStrIdx *foundItem;
f = TclStrIdxTreeSearch(&foundParent, &foundItem, idxTree, s, e);
/* if common prefix was found */
if (f > s) {
/* ignore element if fulfilled or ambigous */
if (f == e) {
continue;
}
/* if shortest key was found with the same value,
* just replace its current key with longest key */
if (foundItem->value == val
&& foundItem->length <= lwrv[i]->length
&& foundItem->length <= (f - s) // only if found item is covered in full
&& foundItem->childTree.firstPtr == NULL) {
TclSetObjRef(foundItem->key, lwrv[i]);
foundItem->length = lwrv[i]->length;
continue;
}
/* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) )
* but don't split by fulfilled child of found item ( ii->iii->iiii ) */
if (foundItem->length != (f - s)) {
/* first split found item (insert one between parent and found + new one) */
item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx));
if (item == NULL) {
goto done;
}
TclInitObjRef(item->key, foundItem->key);
item->length = f - s;
/* set value or mark as ambigous if not the same value of both */
item->value = (foundItem->value == val) ? val : NULL;
/* insert group item between foundParent and foundItem */
TclStrIdxTreeInsertBranch(foundParent, item, foundItem);
foundParent = &item->childTree;
} else {
/* the new item should be added as child of found item */
foundParent = &foundItem->childTree;
}
}
}
/* append item at end of found parent */
item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx));
if (item == NULL) {
goto done;
}
item->childTree.lastPtr = item->childTree.firstPtr = NULL;
TclInitObjRef(item->key, lwrv[i]);
item->length = lwrv[i]->length;
item->value = val;
TclStrIdxTreeAppend(foundParent, item);
}
ret = TCL_OK;
done:
if (lwrv != NULL) {
for (i = 0; i < lstc; i++) {
Tcl_DecrRefCount(lwrv[i]);
}
Tcl_Free(lwrv);
}
if (ret != TCL_OK) {
if (idxTree->firstPtr != NULL) {
TclStrIdxTreeFree(idxTree->firstPtr);
}
}
return ret;
}
/* Is a Tcl_Obj (of right type) holding a smart pointer link? */
static inline int
IsLink(
Tcl_Obj *objPtr)
{
Tcl_ObjInternalRep *irPtr = &objPtr->internalRep;
return irPtr->twoPtrValue.ptr1 && !irPtr->twoPtrValue.ptr2;
}
/* Follow links (smart pointers) if present. */
static inline Tcl_Obj *
FollowPossibleLink(
Tcl_Obj *objPtr)
{
if (IsLink(objPtr)) {
objPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
}
/* assert(!IsLink(objPtr)); */
return objPtr;
}
Tcl_Obj *
TclStrIdxTreeNewObj(void)
{
Tcl_Obj *objPtr = Tcl_NewObj();
TclStrIdxTree *tree = (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue;
/*
* This assert states that we can safely directly have a tree node as the
* internal representation of a Tcl_Obj instead of needing to hang it
* off the back with an extra alloc.
*/
TCL_CT_ASSERT(sizeof(TclStrIdxTree) <= sizeof(Tcl_ObjInternalRep));
tree->firstPtr = NULL;
tree->lastPtr = NULL;
objPtr->typePtr = &StrIdxTreeObjType;
/* return tree root in internal representation */
return objPtr;
}
static void
StrIdxTreeObj_DupIntRepProc(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
/* follow links (smart pointers) */
srcPtr = FollowPossibleLink(srcPtr);
/* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */
TclInitObjRef(*((Tcl_Obj **) ©Ptr->internalRep.twoPtrValue.ptr1),
srcPtr);
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = &StrIdxTreeObjType;
}
static void
StrIdxTreeObj_FreeIntRepProc(
Tcl_Obj *objPtr)
{
/* follow links (smart pointers) */
if (IsLink(objPtr)) {
/* is a link */
TclUnsetObjRef(*((Tcl_Obj **) &objPtr->internalRep.twoPtrValue.ptr1));
} else {
/* is a tree */
TclStrIdxTree *tree = (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue;
if (tree->firstPtr != NULL) {
TclStrIdxTreeFree(tree->firstPtr);
}
tree->firstPtr = NULL;
tree->lastPtr = NULL;
}
objPtr->typePtr = NULL;
}
static void
StrIdxTreeObj_UpdateStringProc(
Tcl_Obj *objPtr)
{
/* currently only dummy empty string possible */
objPtr->length = 0;
objPtr->bytes = &tclEmptyString;
}
TclStrIdxTree *
TclStrIdxTreeGetFromObj(
Tcl_Obj *objPtr)
{
if (objPtr->typePtr != &StrIdxTreeObjType) {
return NULL;
}
/* follow links (smart pointers) */
objPtr = FollowPossibleLink(objPtr);
/* return tree root in internal representation */
return (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue;
}
/*
* Several debug primitives
*/
#ifdef TEST_STR_IDX_TREE
/* currently unused, debug resp. test purposes only */
static void
TclStrIdxTreePrint(
Tcl_Interp *interp,
TclStrIdx *tree,
int offs)
{
Tcl_Obj *obj[2];
const char *s;
TclInitObjRef(obj[0], Tcl_NewStringObj("::puts", TCL_AUTO_LENGTH));
while (tree != NULL) {
s = TclGetString(tree->key) + offs;
TclInitObjRef(obj[1], Tcl_ObjPrintf("%*s%.*s\t:%d",
offs, "", tree->length - offs, s, tree->value));
Tcl_PutsObjCmd(NULL, interp, 2, obj);
TclUnsetObjRef(obj[1]);
if (tree->childTree.firstPtr != NULL) {
TclStrIdxTreePrint(interp, tree->childTree.firstPtr, tree->length);
}
tree = tree->nextPtr;
}
TclUnsetObjRef(obj[0]);
}
int
TclStrIdxTreeTestObjCmd(
void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
const char *cs, *cin, *ret;
static const char *const options[] = {
"findequal", "index", "puts-index", NULL
};
enum optionInd {
O_FINDEQUAL, O_INDEX, O_PUTS_INDEX
};
int optionIndex;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options,
"option", 0, &optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
TclGetString(objv[1]), (char *)NULL);
return TCL_ERROR;
}
switch (optionIndex) {
case O_FINDEQUAL:
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
cs = TclGetString(objv[2]);
cin = TclGetString(objv[3]);
ret = TclUtfFindEqual(
cs, cs + objv[1]->length, cin, cin + objv[2]->length);
Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs));
break;
case O_INDEX:
case O_PUTS_INDEX: {
Tcl_Obj **lstv;
Tcl_Size i, lstc;
TclStrIdxTree idxTree = {NULL, NULL};
i = 1;
while (++i < objc) {
if (TclListObjGetElements(interp, objv[i],
&lstc, &lstv) != TCL_OK) {
return TCL_ERROR;
}
TclStrIdxTreeBuildFromList(&idxTree, lstc, lstv, NULL);
}
if (optionIndex == O_PUTS_INDEX) {
TclStrIdxTreePrint(interp, idxTree.firstPtr, 0);
}
TclStrIdxTreeFree(idxTree.firstPtr);
break;
}
}
return TCL_OK;
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Added generic/tclStrIdxTree.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* tclStrIdxTree.h --
*
* Declarations of string index tries and other primitives currently
* back-ported from tclSE.
*
* Copyright (c) 2016 Serg G. Brester (aka sebres)
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLSTRIDXTREE_H
#define _TCLSTRIDXTREE_H
#include "tclInt.h"
/*
* Main structures declarations of index tree and entry
*/
typedef struct TclStrIdx TclStrIdx;
/*
* Top level structure of the tree, or first two fields of the interior
* structure.
*
* Note that this is EXACTLY two pointers so it is the same size as the
* twoPtrValue of a Tcl_ObjInternalRep. This is how the top level structure
* of the tree is always allocated. (This type constraint is asserted in
* TclStrIdxTreeNewObj() so it's guaranteed.)
*
* Also note that if firstPtr is not NULL, lastPtr must also be not NULL.
* The case where firstPtr is not NULL and lastPtr is NULL is special (a
* smart pointer to one of these) and is not actually a valid instance of
* this structure.
*/
typedef struct TclStrIdxTree {
TclStrIdx *firstPtr;
TclStrIdx *lastPtr;
} TclStrIdxTree;
/*
* An interior node of the tree. Always directly allocated.
*/
struct TclStrIdx {
TclStrIdxTree childTree;
TclStrIdx *nextPtr;
TclStrIdx *prevPtr;
Tcl_Obj *key;
Tcl_Size length;
void *value;
};
/*
*----------------------------------------------------------------------
*
* TclUtfFindEqual, TclUtfFindEqualNC --
*
* Find largest part of string cs in string cin (case sensitive and not).
*
* Results:
* Return position of UTF character in cs after last equal character.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static inline const char *
TclUtfFindEqual(
const char *cs, /* UTF string to find in cin. */
const char *cse, /* End of cs */
const char *cin, /* UTF string will be browsed. */
const char *cine) /* End of cin */
{
const char *ret = cs;
Tcl_UniChar ch1, ch2;
do {
cs += TclUtfToUniChar(cs, &ch1);
cin += TclUtfToUniChar(cin, &ch2);
if (ch1 != ch2) {
break;
}
} while ((ret = cs) < cse && cin < cine);
return ret;
}
static inline const char *
TclUtfFindEqualNC(
const char *cs, /* UTF string to find in cin. */
const char *cse, /* End of cs */
const char *cin, /* UTF string will be browsed. */
const char *cine, /* End of cin */
const char **cinfnd) /* Return position in cin */
{
const char *ret = cs;
Tcl_UniChar ch1, ch2;
do {
cs += TclUtfToUniChar(cs, &ch1);
cin += TclUtfToUniChar(cin, &ch2);
if (ch1 != ch2) {
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
break;
}
}
*cinfnd = cin;
} while ((ret = cs) < cse && cin < cine);
return ret;
}
static inline const char *
TclUtfFindEqualNCInLwr(
const char *cs, /* UTF string (in anycase) to find in cin. */
const char *cse, /* End of cs */
const char *cin, /* UTF string (in lowercase) will be browsed. */
const char *cine, /* End of cin */
const char **cinfnd) /* Return position in cin */
{
const char *ret = cs;
Tcl_UniChar ch1, ch2;
do {
cs += TclUtfToUniChar(cs, &ch1);
cin += TclUtfToUniChar(cin, &ch2);
if (ch1 != ch2) {
ch1 = Tcl_UniCharToLower(ch1);
if (ch1 != ch2) {
break;
}
}
*cinfnd = cin;
} while ((ret = cs) < cse && cin < cine);
return ret;
}
/*
* Primitives to safe set, reset and free references.
*/
#define TclUnsetObjRef(obj) \
do { \
if (obj != NULL) { \
Tcl_DecrRefCount(obj); \
obj = NULL; \
} \
} while (0)
#define TclInitObjRef(obj, val) \
do { \
obj = (val); \
if (obj) { \
Tcl_IncrRefCount(obj); \
} \
} while (0)
#define TclSetObjRef(obj, val) \
do { \
Tcl_Obj *nval = (val); \
if (obj != nval) { \
Tcl_Obj *prev = obj; \
TclInitObjRef(obj, nval); \
if (prev != NULL) { \
Tcl_DecrRefCount(prev); \
} \
} \
} while (0)
/*
* Prototypes of module functions.
*/
MODULE_SCOPE const char*TclStrIdxTreeSearch(TclStrIdxTree **foundParent,
TclStrIdx **foundItem, TclStrIdxTree *tree,
const char *start, const char *end);
MODULE_SCOPE int TclStrIdxTreeBuildFromList(TclStrIdxTree *idxTree,
Tcl_Size lstc, Tcl_Obj **lstv, void **values);
MODULE_SCOPE Tcl_Obj * TclStrIdxTreeNewObj(void);
MODULE_SCOPE TclStrIdxTree*TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr);
#ifdef TEST_STR_IDX_TREE
/* currently unused, debug resp. test purposes only */
MODULE_SCOPE Tcl_ObjCmdProc TclStrIdxTreeTestObjCmd;
#endif
#endif /* _TCLSTRIDXTREE_H */
|
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | #define copysign _copysign #endif #ifndef PRIx64 # define PRIx64 TCL_LL_MODIFIER "x" #endif | < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | #define copysign _copysign #endif #ifndef PRIx64 # define PRIx64 TCL_LL_MODIFIER "x" #endif /* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. */ #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) |
| ︙ | ︙ | |||
121 122 123 124 125 126 127 | #define TWO_OVER_3LOG10 0.28952965460216784 #define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 /* * Definitions of the parts of an IEEE754-format floating point number. */ | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | #define TWO_OVER_3LOG10 0.28952965460216784 #define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 /* * Definitions of the parts of an IEEE754-format floating point number. */ #define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ #define EXP_MASK 0x7FF00000 /* Mask for the exponent field in the first * word of a double. */ #define EXP_SHIFT 20 /* Shift count to make the exponent an * integer. */ |
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | Tcl_WideUInt significand, int nSigDigs, long exponent); #ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); #endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | Tcl_WideUInt significand, int nSigDigs, long exponent); #ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); #endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); static mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR; static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, int *); static void TakeAbsoluteValue(Double *, int *); static char * FormatInfAndNaN(Double *, int *, char **); static char * FormatZero(int *, char **); static int ApproximateLog10(Tcl_WideUInt, int, int); |
| ︙ | ︙ | |||
552 553 554 555 556 557 558 |
if (TclHasInternalRep(objPtr, &tclDictType)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size length;
/* A list can only be a (single) number if its length == 1 */
| | | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 |
if (TclHasInternalRep(objPtr, &tclDictType)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size length;
/* A list can only be a (single) number if its length == 1 */
TclListObjLength(NULL, objPtr, &length);
if (length != 1) {
return TCL_ERROR;
}
}
}
bytes = TclGetString(objPtr);
}
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 | goto endgame; } /* * span multiple numeric whitespace * V * example: 5___6 */ | | | | | | | | | | | | 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 |
goto endgame;
}
/*
* span multiple numeric whitespace
* V
* example: 5___6
*/
for (before = (p - 1);
(before && *before == '_');
before = (before > p ? (before - 1) : NULL));
for (after = (p + 1);
(after && *after && *after == '_');
after = (*after && *after == '_') ? (after + 1) : NULL);
switch (state) {
case ZERO_B:
case BINARY:
if ((before && (*before != '0' && *before != '1')) ||
(after && (*after != '0' && *after != '1'))) {
/* Not a valid digit */
goto endgame;
}
break;
case ZERO_O:
case OCTAL:
if (((before && (*before < '0' || '7' < *before))) ||
((after && (*after < '0' || '7' < *after)))) {
goto endgame;
}
break;
case FRACTION:
case ZERO:
case ZERO_D:
case DECIMAL:
case LEADING_RADIX_POINT:
case EXPONENT_START:
case EXPONENT_SIGNUM:
case EXPONENT:
if ((!before || isdigit(UCHAR(*before))) &&
(!after || isdigit(UCHAR(*after)))) {
break;
}
if (after && *after=='(') {
/* could be function */
goto continue_num;
}
goto endgame;
case ZERO_X:
case HEXADECIMAL:
if ( (!before || isxdigit(UCHAR(*before))) &&
(!after || isxdigit(UCHAR(*after)))) {
break;
}
goto endgame;
default:
/*
* Not whitespace, but could be legal for other reasons.
* Continue number processing for current character.
|
| ︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 |
/*
* Format an error message when an invalid number is encountered.
*/
if (status != TCL_OK) {
if (interp != NULL) {
| | | > > > > > > > | | > | | 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 |
/*
* Format an error message when an invalid number is encountered.
*/
if (status != TCL_OK) {
if (interp != NULL) {
Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got ",
expected);
Tcl_Size argc;
const char **argv;
if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1)
&& Tcl_SplitList(NULL, bytes, &argc, &argv) == TCL_OK) {
Tcl_Free(argv);
Tcl_AppendToObj(msg, "a list", -1);
} else {
Tcl_AppendToObj(msg, "\"", -1);
Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
}
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL);
}
}
/*
* Free memory.
*/
|
| ︙ | ︙ | |||
1693 1694 1695 1696 1697 1698 1699 |
* With gcc on x86, the floating point rounding mode is double-extended.
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
* ulp, so we need to change rounding mode to 53-bits. We also make
* 'retval' volatile, so that it doesn't get promoted to a register.
*/
| | | 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 |
* With gcc on x86, the floating point rounding mode is double-extended.
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
* ulp, so we need to change rounding mode to 53-bits. We also make
* 'retval' volatile, so that it doesn't get promoted to a register.
*/
volatile double retval; /* Value of the number. */
/*
* Test for zero significand, which requires explicit construction
* of -0.0. (Unary minus returns a positive zero.)
*/
if (significand == 0) {
return copysign(0.0, -signum);
|
| ︙ | ︙ | |||
2206 2207 2208 2209 2210 2211 2212 | * Stores base*5**n in result. * *---------------------------------------------------------------------- */ static inline mp_err MulPow5( | | | 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 |
* Stores base*5**n in result.
*
*----------------------------------------------------------------------
*/
static inline mp_err
MulPow5(
mp_int *base, /* Number to multiply. */
unsigned n, /* Power of 5 to multiply by. */
mp_int *result) /* Place to store the result. */
{
mp_int *p = base;
int n13 = n / 13;
int r = n % 13;
mp_err err = MP_OKAY;
|
| ︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 | * one too high. * *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( | | | 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 |
* one too high.
*
*----------------------------------------------------------------------
*/
static inline void
SetPrecisionLimits(
int flags, /* Type of conversion: TCL_DD_SHORTEST,
* TCL_DD_E_FMT, TCL_DD_F_FMT. */
int k, /* Floor(log10(number to convert)) */
int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be
* adjusted if needed). */
int *iPtr, /* OUT: Maximum number of digits to return. */
int *iLimPtr, /* OUT: Number of digits of significance if
* the bignum method is used.*/
|
| ︙ | ︙ | |||
2703 2704 2705 2706 2707 2708 2709 | * "1" and moves the decimal point (*kPtr) one place to the right. * *---------------------------------------------------------------------- */ static inline char * BumpUp( | | | 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 |
* "1" and moves the decimal point (*kPtr) one place to the right.
*
*----------------------------------------------------------------------
*/
static inline char *
BumpUp(
char *s, /* Cursor pointing one past the end of the
* string. */
char *retval, /* Start of the string of digits. */
int *kPtr) /* Position of the decimal point. */
{
while (*--s == '9') {
if (s == retval) {
++(*kPtr);
|
| ︙ | ︙ | |||
3171 3172 3173 3174 3175 3176 3177 |
if (digit > 10) {
Tcl_Panic("wrong digit!");
}
b = b % S;
/*
* Does the current digit put us on the low side of the exact value
| | | 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 |
if (digit > 10) {
Tcl_Panic("wrong digit!");
}
b = b % S;
/*
* Does the current digit put us on the low side of the exact value
* but within roundoff of being exact?
*/
if (b < mplus || (b == mplus
&& (dPtr->w.word1 & 1) == 0)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
* next number above is closer.
|
| ︙ | ︙ | |||
3430 3431 3432 3433 3434 3435 3436 |
/*
* Compare B and S-m - which is the same as comparing B+m and S - which we
* do by computing b+m and doing a bitwhack compare against
* 2**(MP_DIGIT_BIT*sd)
*/
| | > | 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 |
/*
* Compare B and S-m - which is the same as comparing B+m and S - which we
* do by computing b+m and doing a bitwhack compare against
* 2**(MP_DIGIT_BIT*sd)
*/
if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) {
/* Too few digits to be > s */
return 0;
}
if (temp->used > sd+1 || temp->dp[sd] > 1) {
/* >= 2s */
return 1;
}
for (i = sd-1; i >= 0; --i) {
|
| ︙ | ︙ | |||
3568 3569 3570 3571 3572 3573 3574 |
Tcl_Panic("wrong digit!");
}
--b.used; mp_clamp(&b);
}
/*
* Does the current digit put us on the low side of the exact value
| | | 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 |
Tcl_Panic("wrong digit!");
}
--b.used; mp_clamp(&b);
}
/*
* Does the current digit put us on the low side of the exact value
* but within roundoff of being exact?
*/
r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus);
if (r1 == MP_LT || (r1 == MP_EQ
&& (dPtr->w.word1 & 1) == 0)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
|
| ︙ | ︙ | |||
4150 4151 4152 4153 4154 4155 4156 |
}
if (mp_init_u64(&b, bw) != MP_OKAY) {
mp_clear(&dig);
return NULL;
}
err = mp_mul_2d(&b, b2, &b);
if (err == MP_OKAY) {
| | | 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 |
}
if (mp_init_u64(&b, bw) != MP_OKAY) {
mp_clear(&dig);
return NULL;
}
err = mp_mul_2d(&b, b2, &b);
if (err == MP_OKAY) {
err = mp_init_set(&S, 1);
}
if (err == MP_OKAY) {
err = MulPow5(&S, s5, &S);
if (err == MP_OKAY) {
err = mp_mul_2d(&S, s2, &S);
}
}
|
| ︙ | ︙ | |||
4225 4226 4227 4228 4229 4230 4231 | * to int64_t arithmetic. But the potential payoff is tremendously * less - unless we're working in F format - because we know that * three groups of digits will always suffice for %#.17e, the * longest format that doesn't introduce empty precision. * * Extract the next group of digits. */ | < | 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 |
* to int64_t arithmetic. But the potential payoff is tremendously
* less - unless we're working in F format - because we know that
* three groups of digits will always suffice for %#.17e, the
* longest format that doesn't introduce empty precision.
*
* Extract the next group of digits.
*/
if ((err != MP_OKAY) || (mp_div(&b, &S, &dig, &b) != MP_OKAY) || (dig.used > 1)) {
Tcl_Panic("wrong digit!");
}
digit = dig.dp[0];
for (j = g-1; j >= 0; --j) {
int t = itens[j];
|
| ︙ | ︙ | |||
4791 4792 4793 4794 4795 4796 4797 |
*/
if (isinf(d)) {
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
| | | | 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 |
*/
if (isinf(d)) {
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
}
return TCL_ERROR;
}
fract = frexp(d, &expt);
if (expt <= 0) {
err = mp_init(b);
mp_zero(b);
} else {
Tcl_WideInt w = (Tcl_WideInt)ldexp(fract, mantBits);
int shift = expt - mantBits;
err = mp_init_i64(b, w);
if (err != MP_OKAY) {
/* just skip */
} else if (shift < 0) {
err = mp_div_2d(b, -shift, b, NULL);
} else if (shift > 0) {
err = mp_mul_2d(b, shift, b);
}
}
if (err != MP_OKAY) {
|
| ︙ | ︙ | |||
4836 4837 4838 4839 4840 4841 4842 | * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble( | | < | 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 |
* too large to convert.
*
*----------------------------------------------------------------------
*/
double
TclBignumToDouble(
const void *big) /* Integer to convert. */
{
mp_int b;
int bits, shift, i, lsb;
double r;
mp_err err;
const mp_int *a = (const mp_int *)big;
/*
* We need a 'mantBits'-bit significand. Determine what shift will
* give us that.
*/
bits = mp_count_bits(a);
|
| ︙ | ︙ | |||
4958 4959 4960 4961 4962 4963 4964 | * Returns the floating point number. * *---------------------------------------------------------------------- */ double TclCeil( | | | 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 |
* Returns the floating point number.
*
*----------------------------------------------------------------------
*/
double
TclCeil(
const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_err err;
const mp_int *a = (const mp_int *)big;
err = mp_init(&b);
|
| ︙ | ︙ | |||
5024 5025 5026 5027 5028 5029 5030 | * Returns the floating point value. * *---------------------------------------------------------------------- */ double TclFloor( | | | 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 |
* Returns the floating point value.
*
*----------------------------------------------------------------------
*/
double
TclFloor(
const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_err err;
const mp_int *a = (const mp_int *)big;
err = mp_init(&b);
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
1 2 3 | /* * tclStringObj.c -- * | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | /* * tclStringObj.c -- * * This file contains functions that implement string operations on Tcl * objects. Some string operations work with UTF-8 encoding forms. * Functions that require knowledge of the width of each character, * such as indexing, operate on fixed width encoding forms such as UTF-32. * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of * UTF-8 or UTF-32. * * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of * numChars, but we don't store the fixed form encoding (unless * Tcl_GetUnicode is explicitly called). * * The String object type stores one or both formats. The default * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is * stored in the internal rep for future access (without an additional * O(n) cost). * * To allow many appends to be done to an object without constantly * reallocating space, we allocate double the space and use the * internal representation to keep track of how much space is used vs. * allocated. * * Copyright © 1995-1997 Sun Microsystems, Inc. |
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
#ifndef TCL_MIN_UNICHAR_GROWTH
#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
| | | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
#ifndef TCL_MIN_UNICHAR_GROWTH
#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
Tcl_Size needed, /* Not including terminating nul */
int flag) /* If 0, try to overallocate */
{
/*
* Preconditions:
* TclHasInternalRep(objPtr, &tclStringType)
* needed > stringPtr->allocated
* flag || objPtr->bytes != NULL
*/
String *stringPtr = GET_STRING(objPtr);
char *ptr;
Tcl_Size capacity;
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
Tcl_Size needed)
{
/*
* Preconditions:
| | | | | < < < | | 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 |
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
Tcl_Size needed)
{
/*
* Preconditions:
* TclHasInternalRep(objPtr, &tclStringType)
* needed > stringPtr->maxChars
*/
String *stringPtr = GET_STRING(objPtr);
Tcl_Size maxChars;
/* Note STRING_MAXCHARS already takes into account space for nul */
if (needed > STRING_MAXCHARS) {
Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded",
STRING_MAXCHARS);
}
if (stringPtr->maxChars > 0) {
/* Expansion - try allocating extra space */
stringPtr = (String *) TclReallocElemsEx(stringPtr,
needed + 1, /* +1 for nul */
sizeof(Tcl_UniChar), offsetof(String, unicode), &maxChars);
maxChars -= 1; /* End nul not included */
} else {
/*
* First allocation - just big enough. Note needed does
* not include terminating nul but STRING_SIZE does
*/
stringPtr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(needed));
maxChars = needed;
}
|
| ︙ | ︙ | |||
451 452 453 454 455 456 457 |
* but there's no value in that. We *want* to shimmer an improper bytearray
* because improper bytearrays have worthless internal reps.
*/
if (TclIsPureByteArray(objPtr)) {
(void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars);
} else {
| | < | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 |
* but there's no value in that. We *want* to shimmer an improper bytearray
* because improper bytearrays have worthless internal reps.
*/
if (TclIsPureByteArray(objPtr)) {
(void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars);
} else {
TclGetString(objPtr);
numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);
}
return numChars;
}
/*
*----------------------------------------------------------------------
*
* TclCheckEmptyString --
*
* Determine whether the string value of an object is or would be the
|
| ︙ | ︙ | |||
486 487 488 489 490 491 492 |
Tcl_Size length = TCL_INDEX_NONE;
if (objPtr->bytes == &tclEmptyString) {
return TCL_EMPTYSTRING_YES;
}
if (TclIsPureByteArray(objPtr)
| | | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
Tcl_Size length = TCL_INDEX_NONE;
if (objPtr->bytes == &tclEmptyString) {
return TCL_EMPTYSTRING_YES;
}
if (TclIsPureByteArray(objPtr)
&& Tcl_GetCharLength(objPtr) == 0) {
return TCL_EMPTYSTRING_YES;
}
if (TclListObjIsCanonical(objPtr)) {
TclListObjLength(NULL, objPtr, &length);
return length == 0;
}
if (TclIsPureDict(objPtr)) {
Tcl_DictObjSize(NULL, objPtr, &length);
return length == 0;
}
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
int ch = 0;
if (index < 0) {
return -1;
}
/*
| | | | < | | 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 |
int ch = 0;
if (index < 0) {
return -1;
}
/*
* Optimize the ByteArray case: no need to convert to a string to
* perform the indexing operation.
*/
if (TclIsPureByteArray(objPtr)) {
Tcl_Size length = 0;
unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length);
if (index >= length) {
return -1;
}
return bytes[index];
}
Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);
if (index >= numChars) {
return -1;
}
const char *begin = TclUtfAtIndex(objPtr->bytes, index);
TclUtfToUniChar(begin, &ch);
return ch;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj --
|
| ︙ | ︙ | |||
719 720 721 722 723 724 725 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
| | | | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
Tcl_Size first, /* First index of the range. */
Tcl_Size last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
Tcl_Size length = 0;
if (first < 0) {
first = 0;
|
| ︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 |
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The Unicode string to append to the
* object. */
Tcl_Size length) /* Number of chars in Unicode. Negative
| | | 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 |
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The Unicode string to append to the
* object. */
Tcl_Size length) /* Number of chars in Unicode. Negative
* lengths means nul terminated */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
}
|
| ︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 |
}
if (TclCheckEmptyString(objPtr) == TCL_EMPTYSTRING_YES) {
TclSetDuplicateObj(objPtr, appendObjPtr);
return;
}
| < | | < | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 |
}
if (TclCheckEmptyString(objPtr) == TCL_EMPTYSTRING_YES) {
TclSetDuplicateObj(objPtr, appendObjPtr);
return;
}
if (TclIsPureByteArray(appendObjPtr)
&& (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)) {
/*
* Both bytearray objects are pure, so the second internal bytearray value
* can be appended to the first, with no need to modify the "bytes" field.
*/
/*
* One might expect the code here to be
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
if (TclHasInternalRep(appendObjPtr, &tclStringType)) {
Tcl_UniChar *unicode =
Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
| | | | 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 |
if (TclHasInternalRep(appendObjPtr, &tclStringType)) {
Tcl_UniChar *unicode =
Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
bytes = TclGetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
}
/*
* Append to objPtr's UTF string rep. If we know the number of characters
* in both objects before appending, then set the combined number of
* characters in the final (appended-to) object.
*/
bytes = TclGetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) {
String *appendStringPtr = GET_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
}
|
| ︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 |
"\"%n$\" argument index out of range"
};
static const char *overflow = "max size for a Tcl value exceeded";
if (Tcl_IsShared(appendObj)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
| | < < | 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 |
"\"%n$\" argument index out of range"
};
static const char *overflow = "max size for a Tcl value exceeded";
if (Tcl_IsShared(appendObj)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
(void)TclGetStringFromObj(appendObj, &originalLength);
limit = TCL_SIZE_MAX - originalLength;
/*
* 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;
int useWide = 0;
int newXpg, allocSegment = 0;
Tcl_Size numChars, segmentLimit, segmentNumBytes;
Tcl_Obj *segment;
int step = TclUtfToUniChar(format, &ch);
format += step;
if (ch != '%') {
|
| ︙ | ︙ | |||
2085 2086 2087 2088 2089 2090 2091 |
} else if (ch == 'l') {
format += step;
step = TclUtfToUniChar(format, &ch);
if (ch == 'l') {
useBig = 1;
format += step;
step = TclUtfToUniChar(format, &ch);
| < < < < > > > > | > > > > > | | 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 |
} else if (ch == 'l') {
format += step;
step = TclUtfToUniChar(format, &ch);
if (ch == 'l') {
useBig = 1;
format += step;
step = TclUtfToUniChar(format, &ch);
} else {
useWide = 1;
}
} else if (ch == 'I') {
if ((format[1] == '6') && (format[2] == '4')) {
format += (step + 2);
step = TclUtfToUniChar(format, &ch);
useWide = 1;
} else if ((format[1] == '3') && (format[2] == '2')) {
format += (step + 2);
step = TclUtfToUniChar(format, &ch);
} else {
format += step;
step = TclUtfToUniChar(format, &ch);
}
} else if ((ch == 'q') || (ch == 'j')) {
format += step;
step = TclUtfToUniChar(format, &ch);
useWide = 1;
} else if ((ch == 't') || (ch == 'z')) {
format += step;
step = TclUtfToUniChar(format, &ch);
if (sizeof(void *) > sizeof(int)) {
useWide = 1;
}
} else if (ch == 'L') {
format += step;
step = TclUtfToUniChar(format, &ch);
useBig = 1;
}
format += step;
span = format;
|
| ︙ | ︙ | |||
2151 2152 2153 2154 2155 2156 2157 |
char buf[4] = "";
int code, length;
if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
goto error;
}
if ((unsigned)code > 0x10FFFF) {
| | | < | < | > > < | < > > | | | > > | | > > | > > | | > > | 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 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 |
char buf[4] = "";
int code, length;
if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
goto error;
}
if ((unsigned)code > 0x10FFFF) {
code = 0xFFFD;
}
length = Tcl_UniCharToUtf(code, buf);
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
break;
}
case 'u':
/* FALLTHRU */
case 'd':
case 'o':
case 'p':
case 'x':
case 'X':
case 'b': {
short s = 0; /* Silence compiler warning; only defined and
* used when useShort is true. */
int l;
Tcl_WideInt w;
mp_int big;
int isNegative = 0;
Tcl_Size toAppend;
if ((ch == 'p') && (sizeof(void *) > sizeof(int))) {
useWide = 1;
}
if (useBig) {
int cmpResult;
if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
goto error;
}
cmpResult = mp_cmp_d(&big, 0);
isNegative = (cmpResult == MP_LT);
if (cmpResult == MP_EQ) {
gotHash = 0;
}
if (ch == 'u') {
if (isNegative) {
mp_clear(&big);
msg = "unsigned bignum format is invalid";
errCode = "BADUNSIGNED";
goto errorMsg;
} else {
ch = 'd';
}
}
} else if (useWide) {
if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
goto error;
}
isNegative = (w < (Tcl_WideInt) 0);
if (w == (Tcl_WideInt) 0) {
gotHash = 0;
}
} else if (TclGetIntFromObj(NULL, segment, &l) != TCL_OK) {
if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
goto error;
} else {
l = (int) w;
}
if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
if (s == (short) 0) {
gotHash = 0;
}
} else {
isNegative = (l < (int) 0);
if (l == (int) 0) {
gotHash = 0;
}
}
} else if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
if (s == (short) 0) {
gotHash = 0;
}
} else {
isNegative = (l < (int) 0);
if (l == (int) 0) {
gotHash = 0;
}
}
TclNewObj(segment);
allocSegment = 1;
segmentLimit = TCL_SIZE_MAX;
Tcl_IncrRefCount(segment);
|
| ︙ | ︙ | |||
2272 2273 2274 2275 2276 2277 2278 |
case 'd': {
Tcl_Size length;
Tcl_Obj *pure;
const char *bytes;
if (useShort) {
TclNewIntObj(pure, s);
| < < | | 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 |
case 'd': {
Tcl_Size length;
Tcl_Obj *pure;
const char *bytes;
if (useShort) {
TclNewIntObj(pure, s);
} else if (useWide) {
TclNewIntObj(pure, w);
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
TclNewIntObj(pure, l);
}
Tcl_IncrRefCount(pure);
bytes = TclGetStringFromObj(pure, &length);
/*
* Already did the sign above.
*/
if (*bytes == '-') {
length--;
|
| ︙ | ︙ | |||
2360 2361 2362 2363 2364 2365 2366 |
unsigned short us = (unsigned short) s;
bits = (Tcl_WideUInt) us;
while (us) {
numDigits++;
us /= base;
}
| < < | | | 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 |
unsigned short us = (unsigned short) s;
bits = (Tcl_WideUInt) us;
while (us) {
numDigits++;
us /= base;
}
} else if (useWide) {
Tcl_WideUInt uw = (Tcl_WideUInt) w;
bits = uw;
while (uw) {
numDigits++;
uw /= base;
}
} else if (useBig && !mp_iszero(&big)) {
int leftover = (big.used * MP_DIGIT_BIT) % numBits;
mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);
numDigits = 1 +
(((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits);
while ((mask & big.dp[big.used-1]) == 0) {
numDigits--;
mask >>= numBits;
}
if (numDigits > INT_MAX) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
} else if (!useBig) {
unsigned ul = (unsigned) l;
bits = (Tcl_WideUInt) ul;
while (ul) {
numDigits++;
ul /= base;
}
}
/*
* Need to be sure zero becomes "0", not "".
*/
if (numDigits == 0) {
numDigits = 1;
}
TclNewObj(pure);
Tcl_SetObjLength(pure, (Tcl_Size)numDigits);
bytes = TclGetString(pure);
toAppend = length = numDigits;
while (numDigits--) {
int digitOffset;
if (useBig && !mp_iszero(&big)) {
if (index < big.used && (size_t) shift <
|
| ︙ | ︙ | |||
2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 |
*p++ = (char) ch;
*p = '\0';
TclNewObj(segment);
allocSegment = 1;
if (!Tcl_AttemptSetObjLength(segment, length)) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
bytes = TclGetString(segment);
if (!Tcl_AttemptSetObjLength(segment, snprintf(bytes, segment->length, spec, d))) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
if (ch == 'A') {
char *q = TclGetString(segment) + 1;
*q = 'x';
q = strchr(q, 'P');
| > > > > > > | > > | | | 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 |
*p++ = (char) ch;
*p = '\0';
TclNewObj(segment);
allocSegment = 1;
if (!Tcl_AttemptSetObjLength(segment, length)) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
}
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
bytes = TclGetString(segment);
if (!Tcl_AttemptSetObjLength(segment, snprintf(bytes, segment->length, spec, d))) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
}
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
if (ch == 'A') {
char *q = TclGetString(segment) + 1;
*q = 'x';
q = strchr(q, 'P');
if (q) {
*q = 'p';
}
}
break;
}
default:
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("bad field specifier \"%c\"", ch));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (char *)NULL);
}
goto error;
}
if (width>0 && numChars<0) {
numChars = Tcl_GetCharLength(segment);
}
if (!gotMinus && width>0) {
if (numChars < width) {
limit -= width - numChars;
}
while (numChars < width) {
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
numChars++;
}
}
(void)TclGetStringFromObj(segment, &segmentNumBytes);
if (segmentNumBytes > limit) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
}
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
|
| ︙ | ︙ | |||
2608 2609 2610 2611 2612 2613 2614 |
}
return TCL_OK;
errorMsg:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
| | | 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 |
}
return TCL_OK;
errorMsg:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, (char *)NULL);
}
error:
Tcl_SetObjLength(appendObj, originalLength);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
2858 2859 2860 2861 2862 2863 2864 |
size = -1;
/* FALLTHRU */
default:
p++;
}
} while (seekingConversion);
}
| | | 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 |
size = -1;
/* FALLTHRU */
default:
p++;
}
} while (seekingConversion);
}
TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
"Unable to format \"%s\" with supplied arguments: %s",
format, TclGetString(list));
}
Tcl_DecrRefCount(list);
|
| ︙ | ︙ | |||
2949 2950 2951 2952 2953 2954 2955 |
TclGetStringStorage(
Tcl_Obj *objPtr,
Tcl_Size *sizePtr)
{
String *stringPtr;
if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
| | | | | | 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 |
TclGetStringStorage(
Tcl_Obj *objPtr,
Tcl_Size *sizePtr)
{
String *stringPtr;
if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
return TclGetStringFromObj(objPtr, sizePtr);
}
stringPtr = GET_STRING(objPtr);
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
/*
*---------------------------------------------------------------------------
*
* TclStringRepeat --
*
* Performs the [string repeat] function.
*
* Results:
* A (Tcl_Obj *) pointing to the result value, or NULL in case of an
* error.
*
* Side effects:
* On error, when interp is not NULL, error information is left in it.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringRepeat(
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
2992 2993 2994 2995 2996 2997 2998 |
Tcl_Size done = 1;
int binary = TclIsPureByteArray(objPtr);
Tcl_Size maxCount;
/*
* Analyze to determine what representation result should be.
* GOALS: Avoid shimmering & string rep generation.
| | | | 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 |
Tcl_Size done = 1;
int binary = TclIsPureByteArray(objPtr);
Tcl_Size maxCount;
/*
* Analyze to determine what representation result should be.
* GOALS: Avoid shimmering & string rep generation.
* Produce pure bytearray when possible.
* Error on overflow.
*/
if (!binary) {
if (TclHasInternalRep(objPtr, &tclStringType)) {
String *stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode) {
unichar = 1;
|
| ︙ | ︙ | |||
3015 3016 3017 3018 3019 3020 3021 |
maxCount = TCL_SIZE_MAX;
} else if (unichar) {
/* Result will be pure Tcl_UniChar array. Pre-size it. */
(void)Tcl_GetUnicodeFromObj(objPtr, &length);
maxCount = TCL_SIZE_MAX/sizeof(Tcl_UniChar);
} else {
/* Result will be concat of string reps. Pre-size it. */
| | | < | | < | | 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 |
maxCount = TCL_SIZE_MAX;
} else if (unichar) {
/* Result will be pure Tcl_UniChar array. Pre-size it. */
(void)Tcl_GetUnicodeFromObj(objPtr, &length);
maxCount = TCL_SIZE_MAX/sizeof(Tcl_UniChar);
} else {
/* Result will be concat of string reps. Pre-size it. */
(void)TclGetStringFromObj(objPtr, &length);
maxCount = TCL_SIZE_MAX;
}
if (length == 0) {
/* Any repeats of empty is empty. */
return objPtr;
}
/* maxCount includes space for null */
if (count > (maxCount-1)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%" TCL_SIZE_MODIFIER
"d bytes) exceeded", TCL_SIZE_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
if (binary) {
/* Efficiently produce a pure byte array result */
objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ?
|
| ︙ | ︙ | |||
3071 3072 3073 3074 3075 3076 3077 |
/* TODO - overflow check */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %"
TCL_SIZE_MODIFIER "d bytes",
STRING_SIZE(count*length)));
| | | 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 |
/* TODO - overflow check */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %"
TCL_SIZE_MODIFIER "d bytes",
STRING_SIZE(count*length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
Tcl_SetObjLength(objResultPtr, length);
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
|
| ︙ | ︙ | |||
3099 3100 3101 3102 3103 3104 3105 |
}
/* TODO - overflow check */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
count*length));
| | | 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 |
}
/* TODO - overflow check */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
count*length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
Tcl_SetObjLength(objResultPtr, length);
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
|
| ︙ | ︙ | |||
3122 3123 3124 3125 3126 3127 3128 | *--------------------------------------------------------------------------- * * TclStringCat -- * * Performs the [string cat] function. * * Results: | | | | | 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 |
*---------------------------------------------------------------------------
*
* TclStringCat --
*
* Performs the [string cat] function.
*
* Results:
* A (Tcl_Obj *) pointing to the result value, or NULL in case of an
* error.
*
* Side effects:
* On error, when interp is not NULL, error information is left in it.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringCat(
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
3160 3161 3162 3163 3164 3165 3166 |
/* One object; return first */
return objv[0];
}
/*
* Analyze to determine what representation result should be.
* GOALS: Avoid shimmering & string rep generation.
| | | | | | | | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 |
/* One object; return first */
return objv[0];
}
/*
* Analyze to determine what representation result should be.
* GOALS: Avoid shimmering & string rep generation.
* Produce pure bytearray when possible.
* Error on overflow.
*/
ov = objv, oc = objc;
do {
Tcl_Obj *objPtr = *ov++;
if (TclIsPureByteArray(objPtr)) {
allowUniChar = 0;
} else if (objPtr->bytes) {
/* Value has a string rep. */
if (objPtr->length) {
/*
* Non-empty string rep. Not a pure bytearray, so we won't
* create a pure bytearray.
*/
binary = 0;
if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
forceUniChar = 1;
} else if ((objPtr->typePtr) && !TclHasInternalRep(objPtr, &tclStringType)) {
/* Prevent shimmer of non-string types. */
allowUniChar = 0;
}
}
} else {
binary = 0;
if (TclHasInternalRep(objPtr, &tclStringType)) {
|
| ︙ | ︙ | |||
3271 3272 3273 3274 3275 3276 3277 |
* Keep string rep generation pending when possible.
*/
do {
Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes == NULL
| | | | | | | | | | 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 |
* Keep string rep generation pending when possible.
*/
do {
Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes == NULL
&& TclCheckEmptyString(objPtr) != TCL_EMPTYSTRING_YES) {
/* No string rep; Take the chance we can avoid making it */
pendingPtr = objPtr;
} else {
(void) TclGetStringFromObj(objPtr, &length); /* PANIC? */
}
} while (--oc && (length == 0) && (pendingPtr == NULL));
/*
* Either we found a possibly non-empty value, and we remember
* this index as the first and last such value so far seen,
* or (oc == 0) and all values are known empty,
* so first = last = objc - 1 signals the right quick return.
*/
first = last = objc - oc - 1;
if (oc && (length == 0)) {
Tcl_Size numBytes;
/*
* There's a pending value followed by more values. Loop over
* remaining values generating strings until a non-empty value
* is found, or the pending value gets its string generated.
*/
do {
Tcl_Obj *objPtr = *ov++;
(void)TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */
} while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
if (numBytes) {
last = objc -oc -1;
}
if (oc || numBytes) {
(void)TclGetStringFromObj(pendingPtr, &length);
}
if (length == 0) {
if (numBytes) {
first = last;
}
} else if (numBytes > (TCL_SIZE_MAX - length)) {
goto overflow;
|
| ︙ | ︙ | |||
3395 3396 3397 3398 3399 3400 3401 |
/* Ugly interface! Force resize of the unicode array. */
(void)Tcl_GetUnicodeFromObj(objResultPtr, &start);
Tcl_InvalidateStringRep(objResultPtr);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | | | 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 |
/* Ugly interface! Force resize of the unicode array. */
(void)Tcl_GetUnicodeFromObj(objResultPtr, &start);
Tcl_InvalidateStringRep(objResultPtr);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
TCL_Z_MODIFIER "u bytes",
STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
dst = Tcl_GetUnicode(objResultPtr) + start;
} else {
Tcl_UniChar ch = 0;
/* Ugly interface! No scheme to init array size. */
objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
Tcl_DecrRefCount(objResultPtr);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
TCL_Z_MODIFIER "u bytes",
STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
dst = Tcl_GetUnicode(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
|
| ︙ | ︙ | |||
3440 3441 3442 3443 3444 3445 3446 |
char *dst;
if (inPlace) {
Tcl_Size start;
objResultPtr = *objv++; objc--;
| | | | | | | | > | < | | | | | 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 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 |
char *dst;
if (inPlace) {
Tcl_Size start;
objResultPtr = *objv++; objc--;
(void)TclGetStringFromObj(objResultPtr, &start);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
dst = TclGetString(objResultPtr) + start;
TclFreeInternalRep(objResultPtr);
} else {
TclNewObj(objResultPtr); /* PANIC? */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
Tcl_DecrRefCount(objResultPtr);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
dst = TclGetString(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
Tcl_Size more;
char *src = TclGetStringFromObj(objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
/* Must NUL-terminate! */
*dst = '\0';
}
return objResultPtr;
overflow:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%" TCL_SIZE_MODIFIER
"d bytes) exceeded", TCL_SIZE_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* TclStringCmp --
* Compare two Tcl_Obj values as strings.
*
* Results:
* Like memcmp, return -1, 0, or 1.
*
* 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
|
| ︙ | ︙ | |||
3566 3567 3568 3569 3570 3571 3572 |
return 0;
}
static int
UtfNcasememcmp(
const void *csPtr, /* UTF string to compare to ct. */
const void *ctPtr, /* UTF string cs is compared to. */
| | | 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 |
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) {
/*
|
| ︙ | ︙ | |||
3593 3594 3595 3596 3597 3598 3599 |
}
}
return 0;
}
static int
UniCharNmemcmp(
| | | | | 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 |
}
}
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
*/
|
| ︙ | ︙ | |||
3627 3628 3629 3630 3631 3632 3633 |
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;
| | | 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 |
int
TclStringCmp(
Tcl_Obj *value1Ptr,
Tcl_Obj *value2Ptr,
int checkEq, /* comparison is only for equality */
int nocase, /* comparison is not case sensitive */
Tcl_Size reqlength) /* requested length in characters;
* TCL_INDEX_NONE to compare whole strings */
{
const char *s1, *s2;
int empty, match;
Tcl_Size length, s1len = 0, s2len = 0;
memCmpFn_t memCmpFn;
if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
|
| ︙ | ︙ | |||
3673 3674 3675 3676 3677 3678 3679 |
} else {
s1len = Tcl_GetCharLength(value1Ptr);
s2len = Tcl_GetCharLength(value2Ptr);
if ((s1len == value1Ptr->length)
&& (value1Ptr->bytes != NULL)
&& (s2len == value2Ptr->length)
&& (value2Ptr->bytes != NULL)) {
| | | < | 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 |
} else {
s1len = Tcl_GetCharLength(value1Ptr);
s2len = Tcl_GetCharLength(value2Ptr);
if ((s1len == value1Ptr->length)
&& (value1Ptr->bytes != NULL)
&& (s2len == value2Ptr->length)
&& (value2Ptr->bytes != NULL)) {
/* each byte represents one character so s1l3n, s2l3n,
* and reqlength are in both bytes and characters */
s1 = value1Ptr->bytes;
s2 = value2Ptr->bytes;
memCmpFn = memcmp;
} else {
s1 = (char *) Tcl_GetUnicode(value1Ptr);
s2 = (char *) Tcl_GetUnicode(value2Ptr);
if (
|
| ︙ | ︙ | |||
3705 3706 3707 3708 3709 3710 3711 |
}
}
} else {
empty = TclCheckEmptyString(value1Ptr);
if (empty > 0) {
switch (TclCheckEmptyString(value2Ptr)) {
case -1:
| | | | | | | | 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 |
}
}
} else {
empty = TclCheckEmptyString(value1Ptr);
if (empty > 0) {
switch (TclCheckEmptyString(value2Ptr)) {
case -1:
s1 = "";
s1len = 0;
s2 = TclGetStringFromObj(value2Ptr, &s2len);
break;
case 0:
match = -1;
goto matchdone;
case 1:
default: /* avoid warn: `s2` may be used uninitialized */
match = 0;
goto matchdone;
}
} else if (TclCheckEmptyString(value2Ptr) > 0) {
switch (empty) {
case -1:
s2 = "";
s2len = 0;
s1 = TclGetStringFromObj(value1Ptr, &s1len);
break;
case 0:
match = 1;
goto matchdone;
case 1:
default: /* avoid warn: `s1` may be used uninitialized */
match = 0;
goto matchdone;
}
} else {
s1 = TclGetStringFromObj(value1Ptr, &s1len);
s2 = TclGetStringFromObj(value2Ptr, &s2len);
}
if (!nocase && checkEq && reqlength < 0) {
/*
* When we have equal-length we can check only for
* (in)equality. We can use memcmp in all (n)eq cases because
* we don't need to worry about lexical LE/BE variance.
*/
|
| ︙ | ︙ | |||
3936 3937 3938 3939 3940 3941 3942 |
Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle);
Tcl_Size value = -1;
Tcl_UniChar *checkStr, *uh, *un;
Tcl_Obj *obj;
if (ln == 0) {
/*
| | | | | 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 |
Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle);
Tcl_Size value = -1;
Tcl_UniChar *checkStr, *uh, *un;
Tcl_Obj *obj;
if (ln == 0) {
/*
* We don't find empty substrings. Bizarre!
*
* TODO: When we one day make this a true substring
* finder, change this to "return last", after limitation.
*/
goto lastEnd;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *check, *bh = Tcl_GetBytesFromObj(NULL, haystack, &lh);
unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln);
|
| ︙ | ︙ | |||
4120 4121 4122 4123 4124 4125 4126 |
while (bytesLeft) {
/*
* NOTE: We know that the from buffer is NUL-terminated. It's
* part of the contract for objPtr->bytes values. Thus, we can
* skip calling Tcl_UtfCharComplete() here.
*/
| | | 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 |
while (bytesLeft) {
/*
* NOTE: We know that the from buffer is NUL-terminated. It's
* part of the contract for objPtr->bytes values. Thus, we can
* skip calling Tcl_UtfCharComplete() here.
*/
int bytesInChar = TclUtfToUniChar(from, &chw);
ReverseBytes((unsigned char *)to, (unsigned char *)from,
bytesInChar);
to += bytesInChar;
from += bytesInChar;
bytesLeft -= bytesInChar;
}
|
| ︙ | ︙ | |||
4239 4240 4241 4242 4243 4244 4245 |
}
if (newBytes > (TCL_SIZE_MAX - (numBytes - count))) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded",
TCL_SIZE_MAX));
| | | 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 |
}
if (newBytes > (TCL_SIZE_MAX - (numBytes - count))) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded",
TCL_SIZE_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
return NULL;
}
result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
/* PANIC? */
Tcl_SetByteArrayLength(result, 0);
TclAppendBytesToByteArray(result, bytes, first);
|
| ︙ | ︙ |
Changes to generic/tclStringRep.h.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLSTRINGREP #define _TCLSTRINGREP | < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLSTRINGREP #define _TCLSTRINGREP /* * The following structure is the internal rep for a String object. It keeps * track of how much memory has been used and how much has been allocated for * the various representations to enable growing and shrinking of * the String object with fewer mallocs. To optimize string * length and indexing operations, this structure also stores the number of * code points (independent of encoding form) once that value has been computed. |
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | #undef Tcl_DictObjSize #undef Tcl_SplitList #undef Tcl_SplitPath #undef Tcl_FSSplitPath #undef Tcl_ParseArgsObjv #undef TclStaticLibrary #define TclStaticLibrary Tcl_StaticLibrary | < < < < < | | < > > > | | | | | | | | | | > > > > > > > > > > > > > > > > < | 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 |
#undef Tcl_DictObjSize
#undef Tcl_SplitList
#undef Tcl_SplitPath
#undef Tcl_FSSplitPath
#undef Tcl_ParseArgsObjv
#undef TclStaticLibrary
#define TclStaticLibrary Tcl_StaticLibrary
#undef TclObjInterpProc
#if !defined(_WIN32) && !defined(__CYGWIN__)
# undef Tcl_WinConvertError
# define Tcl_WinConvertError 0
#endif
#undef TclGetStringFromObj
#if defined(TCL_NO_DEPRECATED)
# define TclGetStringFromObj 0
# define TclGetBytesFromObj 0
# define TclGetUnicodeFromObj 0
#endif
#undef Tcl_Close
#define Tcl_Close 0
#undef Tcl_GetByteArrayFromObj
#define Tcl_GetByteArrayFromObj 0
#define TclUnusedStubEntry 0
#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev
#undef TclListObjGetElements
#undef TclListObjLength
#if defined(TCL_NO_DEPRECATED)
# define TclListObjGetElements 0
# define TclListObjLength 0
# define TclDictObjSize 0
# define TclSplitList 0
# define TclSplitPath 0
# define TclFSSplitPath 0
# define TclParseArgsObjv 0
# define TclGetAliasObj 0
#else /* !defined(TCL_NO_DEPRECATED) */
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
void *objcPtr, Tcl_Obj ***objvPtr) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
if (objcPtr) {
if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", (char *)NULL);
}
return TCL_ERROR;
}
*(int *)objcPtr = (int)n;
}
return result;
}
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
void *lengthPtr) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_ListObjLength(interp, listPtr, &n);
if (lengthPtr) {
if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", (char *)NULL);
}
return TCL_ERROR;
}
*(int *)lengthPtr = (int)n;
}
return result;
}
int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
void *sizePtr) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_DictObjSize(interp, dictPtr, &n);
if (sizePtr) {
if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "Dict too large to be processed", (char *)NULL);
}
return TCL_ERROR;
}
*(int *)sizePtr = (int)n;
}
return result;
}
int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
const char ***argvPtr) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
if (argcPtr) {
if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", (char *)NULL);
}
Tcl_Free((void *)*argvPtr);
return TCL_ERROR;
}
*(int *)argcPtr = (int)n;
}
return result;
}
void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) {
Tcl_Size n = TCL_INDEX_NONE;
Tcl_SplitPath(path, &n, argvPtr);
if (argcPtr) {
if ((sizeof(int) != sizeof(Tcl_Size)) && (n > INT_MAX)) {
n = TCL_INDEX_NONE; /* No other way to return an error-situation */
Tcl_Free((void *)*argvPtr);
*argvPtr = NULL;
}
*(int *)argcPtr = (int)n;
}
}
Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) {
Tcl_Size n = TCL_INDEX_NONE;
Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
if (lenPtr) {
if ((sizeof(int) != sizeof(Tcl_Size)) && result && (n > INT_MAX)) {
Tcl_DecrRefCount(result);
return NULL;
}
*(int *)lenPtr = (int)n;
}
return result;
}
int TclParseArgsObjv(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv,
Tcl_Obj ***remObjv) {
Tcl_Size n = (*(int *)objcPtr < 0) ? TCL_INDEX_NONE: (Tcl_Size)*(int *)objcPtr ;
int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
*(int *)objcPtr = (int)n;
return result;
}
int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv) {
Tcl_Size n = TCL_INDEX_NONE;
int result = Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, &n, objv);
if (objcPtr) {
if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", NULL);
}
return TCL_ERROR;
}
*objcPtr = (int)n;
}
return result;
}
#endif /* !defined(TCL_NO_DEPRECATED) */
#define TclBN_mp_add mp_add
#define TclBN_mp_add_d mp_add_d
#define TclBN_mp_and mp_and
#define TclBN_mp_clamp mp_clamp
#define TclBN_mp_clear mp_clear
#define TclBN_mp_clear_multi mp_clear_multi
#define TclBN_mp_cmp mp_cmp
#define TclBN_mp_cmp_d mp_cmp_d
#define TclBN_mp_cmp_mag mp_cmp_mag
#define TclBN_mp_cnt_lsb mp_cnt_lsb
#define TclBN_mp_copy mp_copy
#define TclBN_mp_count_bits mp_count_bits
#define TclBN_mp_div mp_div
#define TclBN_mp_div_d mp_div_d
#define TclBN_mp_div_2 mp_div_2
#define TclBN_mp_div_2d mp_div_2d
#define TclBN_mp_exch mp_exch
#define TclBN_mp_get_mag_u64 mp_get_mag_u64
#define TclBN_mp_grow mp_grow
#define TclBN_mp_init mp_init
#define TclBN_mp_init_copy mp_init_copy
#define TclBN_mp_init_multi mp_init_multi
#define TclBN_mp_init_set mp_init_set
#define TclBN_mp_init_size mp_init_size
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 254 255 | #define TclBN_mp_to_ubin mp_to_ubin #define TclBN_mp_ubin_size mp_ubin_size #define TclBN_mp_unpack mp_unpack #define TclBN_mp_xor mp_xor #define TclBN_mp_zero mp_zero #define TclBN_s_mp_add s_mp_add #define TclBN_mp_balance_mul s_mp_balance_mul #define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul #define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr | > | | | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 | #define TclBN_mp_to_ubin mp_to_ubin #define TclBN_mp_ubin_size mp_ubin_size #define TclBN_mp_unpack mp_unpack #define TclBN_mp_xor mp_xor #define TclBN_mp_zero mp_zero #define TclBN_s_mp_add s_mp_add #define TclBN_mp_balance_mul s_mp_balance_mul #define TclBN_mp_div_3 s_mp_div_3 #define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul #define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr #define TclBN_mp_mul_digs s_mp_mul_digs #define TclBN_mp_mul_digs_fast s_mp_mul_digs_fast #define TclBN_mp_reverse s_mp_reverse #define TclBN_s_mp_sqr s_mp_sqr #define TclBN_mp_sqr_fast s_mp_sqr_fast #define TclBN_s_mp_sub s_mp_sub #define TclBN_mp_toom_mul s_mp_toom_mul #define TclBN_mp_toom_sqr s_mp_toom_sqr #ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ # define Tcl_MacOSXOpenVersionedBundleResources 0 # define Tcl_MacOSXNotifierAddRunLoopMode 0 |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
if (*p == '\\') {
*p = '/';
}
}
return path;
}
| | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
if (*p == '\\') {
*p = '/';
}
}
return path;
}
void *TclWinGetTclInstance(void)
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
* without introducing a binary incompatibility.
*/
#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
| | | | | | 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 |
* without introducing a binary incompatibility.
*/
#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))(void *)exprInt
static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
long longValue;
int result = Tcl_ExprLongObj(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
result = TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
* The rest of this file shouldn't warn about deprecated functions; they're
* there because we intend them to be so and know that this file is OK to
* touch those fields.
*/
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#endif
/* !BEGIN!: Do not edit below this line. */
static const TclIntStubs tclIntStubs = {
TCL_STUB_MAGIC,
0,
0, /* 0 */
0, /* 1 */
| > > > > > > > > > > > | 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 |
* The rest of this file shouldn't warn about deprecated functions; they're
* there because we intend them to be so and know that this file is OK to
* touch those fields.
*/
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#endif
#ifdef TCL_WITH_EXTERNAL_TOMMATH
/* If Tcl is linked with an external libtommath 1.2.x, then mp_expt_n doesn't
* exist (since that was introduced in libtommath 1.3.0. Provide it here.) */
mp_err MP_WUR TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c) {
if ((unsigned)b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
return mp_expt_u32(a, (uint32_t)b, c);;
}
#endif /* TCL_WITH_EXTERNAL_TOMMATH */
/* !BEGIN!: Do not edit below this line. */
static const TclIntStubs tclIntStubs = {
TCL_STUB_MAGIC,
0,
0, /* 0 */
0, /* 1 */
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
TclBN_mp_count_bits, /* 12 */
TclBN_mp_div, /* 13 */
TclBN_mp_div_d, /* 14 */
TclBN_mp_div_2, /* 15 */
TclBN_mp_div_2d, /* 16 */
0, /* 17 */
TclBN_mp_exch, /* 18 */
| | | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
TclBN_mp_count_bits, /* 12 */
TclBN_mp_div, /* 13 */
TclBN_mp_div_d, /* 14 */
TclBN_mp_div_2, /* 15 */
TclBN_mp_div_2d, /* 16 */
0, /* 17 */
TclBN_mp_exch, /* 18 */
TclBN_mp_expt_n, /* 19 */
TclBN_mp_grow, /* 20 */
TclBN_mp_init, /* 21 */
TclBN_mp_init_copy, /* 22 */
TclBN_mp_init_multi, /* 23 */
TclBN_mp_init_set, /* 24 */
TclBN_mp_init_size, /* 25 */
TclBN_mp_lshd, /* 26 */
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
Tcl_ExprObj, /* 141 */
Tcl_ExprString, /* 142 */
Tcl_Finalize, /* 143 */
0, /* 144 */
Tcl_FirstHashEntry, /* 145 */
Tcl_Flush, /* 146 */
0, /* 147 */
| | | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 |
Tcl_ExprObj, /* 141 */
Tcl_ExprString, /* 142 */
Tcl_Finalize, /* 143 */
0, /* 144 */
Tcl_FirstHashEntry, /* 145 */
Tcl_Flush, /* 146 */
0, /* 147 */
0, /* 148 */
TclGetAliasObj, /* 149 */
Tcl_GetAssocData, /* 150 */
Tcl_GetChannel, /* 151 */
Tcl_GetChannelBufferSize, /* 152 */
Tcl_GetChannelHandle, /* 153 */
Tcl_GetChannelInstanceData, /* 154 */
Tcl_GetChannelMode, /* 155 */
Tcl_GetChannelName, /* 156 */
|
| ︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 |
0, /* 278 */
Tcl_GetVersion, /* 279 */
Tcl_InitMemory, /* 280 */
Tcl_StackChannel, /* 281 */
Tcl_UnstackChannel, /* 282 */
Tcl_GetStackedChannel, /* 283 */
Tcl_SetMainLoop, /* 284 */
| | | 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 |
0, /* 278 */
Tcl_GetVersion, /* 279 */
Tcl_InitMemory, /* 280 */
Tcl_StackChannel, /* 281 */
Tcl_UnstackChannel, /* 282 */
Tcl_GetStackedChannel, /* 283 */
Tcl_SetMainLoop, /* 284 */
Tcl_GetAliasObj, /* 285 */
Tcl_AppendObjToObj, /* 286 */
Tcl_CreateEncoding, /* 287 */
Tcl_CreateThreadExitHandler, /* 288 */
Tcl_DeleteThreadExitHandler, /* 289 */
0, /* 290 */
Tcl_EvalEx, /* 291 */
Tcl_EvalObjv, /* 292 */
|
| ︙ | ︙ | |||
1448 1449 1450 1451 1452 1453 1454 |
Tcl_GetBytesFromObj, /* 650 */
Tcl_GetStringFromObj, /* 651 */
Tcl_GetUnicodeFromObj, /* 652 */
Tcl_GetSizeIntFromObj, /* 653 */
Tcl_UtfCharComplete, /* 654 */
Tcl_UtfNext, /* 655 */
Tcl_UtfPrev, /* 656 */
| | | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 |
Tcl_GetBytesFromObj, /* 650 */
Tcl_GetStringFromObj, /* 651 */
Tcl_GetUnicodeFromObj, /* 652 */
Tcl_GetSizeIntFromObj, /* 653 */
Tcl_UtfCharComplete, /* 654 */
Tcl_UtfNext, /* 655 */
Tcl_UtfPrev, /* 656 */
Tcl_FSTildeExpand, /* 657 */
Tcl_ExternalToUtfDStringEx, /* 658 */
Tcl_UtfToExternalDStringEx, /* 659 */
Tcl_AsyncMarkFromSignal, /* 660 */
Tcl_ListObjGetElements, /* 661 */
Tcl_ListObjLength, /* 662 */
Tcl_DictObjSize, /* 663 */
Tcl_SplitList, /* 664 */
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 |
Tcl_GetNumber, /* 681 */
Tcl_RemoveChannelMode, /* 682 */
Tcl_GetEncodingNulLength, /* 683 */
Tcl_GetWideUIntFromObj, /* 684 */
Tcl_DStringToObj, /* 685 */
Tcl_UtfNcmp, /* 686 */
Tcl_UtfNcasecmp, /* 687 */
| > > | | 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
Tcl_GetNumber, /* 681 */
Tcl_RemoveChannelMode, /* 682 */
Tcl_GetEncodingNulLength, /* 683 */
Tcl_GetWideUIntFromObj, /* 684 */
Tcl_DStringToObj, /* 685 */
Tcl_UtfNcmp, /* 686 */
Tcl_UtfNcasecmp, /* 687 */
Tcl_NewWideUIntObj, /* 688 */
Tcl_SetWideUIntObj, /* 689 */
TclUnusedStubEntry, /* 690 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclStubLibTbl.c.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | * Side effects: * Sets the stub table pointers. * *---------------------------------------------------------------------- */ MODULE_SCOPE const char * TclInitStubTable( | | | | | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE const char *
TclInitStubTable(
const char *version) /* points to the version field of a
* structure variable. */
{
if (version) {
if (tclStubsHandle == NULL) {
/* This can only happen with -DBUILD_STATIC, so simulate
* that the loading of Tcl succeeded, although we didn't
* actually load it dynamically */
tclStubsHandle = (void *)1;
}
tclStubsPtr = ((const TclStubs **) version)[-1];
if (tclStubsPtr->hooks) {
tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 24 | #define TCL_8_API #undef BUILD_tcl #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" | > < < < < < | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #define TCL_8_API #undef BUILD_tcl #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */ #include "tclInt.h" #include "tclOO.h" #include <math.h> /* * Required for Testregexp*Cmd */ #include "tclRegexp.h" |
| ︙ | ︙ | |||
175 176 177 178 179 180 181 | static Tcl_ThreadCreateType AsyncThreadProc(void *); static void CleanupTestSetassocdataTests( void *clientData, Tcl_Interp *interp); static void CmdDelProc1(void *clientData); static void CmdDelProc2(void *clientData); static Tcl_CmdProc CmdProc1; static Tcl_CmdProc CmdProc2; | | < < < < | < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | > | | | | | | | | | 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 | static Tcl_ThreadCreateType AsyncThreadProc(void *); static void CleanupTestSetassocdataTests( void *clientData, Tcl_Interp *interp); static void CmdDelProc1(void *clientData); static void CmdDelProc2(void *clientData); static Tcl_CmdProc CmdProc1; static Tcl_CmdProc CmdProc2; static Tcl_CmdObjTraceProc CmdTraceDeleteProc; static Tcl_CmdObjTraceProc CmdTraceProc; static Tcl_ObjCmdProc CreatedCommandProc; static Tcl_ObjCmdProc CreatedCommandProc2; static void DelCallbackProc(void *clientData, Tcl_Interp *interp); static Tcl_ObjCmdProc DelCmdProc; static void DelDeleteProc(void *clientData); static void EncodingFreeProc(void *clientData); static int EncodingToUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static int EncodingFromUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static void ExitProcEven(void *clientData); static void ExitProcOdd(void *clientData); static Tcl_ObjCmdProc GetTimesCmd; static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver; static void MainLoop(void); static Tcl_CmdProc NoopCmd; static Tcl_ObjCmdProc NoopObjCmd; static Tcl_CmdObjTraceProc TraceProc; static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static Tcl_FreeProc SpecialFree; static int StaticInitProc(Tcl_Interp *interp); static Tcl_ObjCmdProc TestasyncCmd; static Tcl_ObjCmdProc TestbumpinterpepochCmd; static Tcl_ObjCmdProc TestbytestringCmd; static Tcl_ObjCmdProc TestsetbytearraylengthCmd; static Tcl_ObjCmdProc TestpurebytesobjCmd; static Tcl_ObjCmdProc TeststringbytesCmd; static Tcl_ObjCmdProc2 Testcmdobj2Cmd; static Tcl_ObjCmdProc TestcmdinfoCmd; static Tcl_ObjCmdProc TestcmdtokenCmd; static Tcl_ObjCmdProc TestcmdtraceCmd; static Tcl_ObjCmdProc TestconcatobjCmd; static Tcl_ObjCmdProc TestcreatecommandCmd; static Tcl_ObjCmdProc TestdcallCmd; static Tcl_ObjCmdProc TestdelCmd; static Tcl_ObjCmdProc TestdelassocdataCmd; static Tcl_ObjCmdProc TestdoubledigitsCmd; static Tcl_ObjCmdProc TestdstringCmd; static Tcl_ObjCmdProc TestencodingCmd; static Tcl_ObjCmdProc TestevalexCmd; static Tcl_ObjCmdProc TestevalobjvCmd; static Tcl_ObjCmdProc TesteventCmd; static int TesteventProc(Tcl_Event *event, int flags); static int TesteventDeleteProc(Tcl_Event *event, void *clientData); static Tcl_ObjCmdProc TestexithandlerCmd; static Tcl_ObjCmdProc TestexprlongCmd; static Tcl_ObjCmdProc TestexprlongobjCmd; static Tcl_ObjCmdProc TestexprdoubleCmd; static Tcl_ObjCmdProc TestexprdoubleobjCmd; static Tcl_ObjCmdProc TestexprparserCmd; static Tcl_ObjCmdProc TestexprstringCmd; static Tcl_ObjCmdProc TestfileCmd; static Tcl_ObjCmdProc TestfilelinkCmd; static Tcl_ObjCmdProc TestfeventCmd; static Tcl_ObjCmdProc TestgetassocdataCmd; static Tcl_ObjCmdProc TestgetintCmd; static Tcl_ObjCmdProc TestlongsizeCmd; static Tcl_ObjCmdProc TestgetplatformCmd; static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_ObjCmdProc TestinterpdeleteCmd; static Tcl_ObjCmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; static Tcl_ObjCmdProc TestlistrepCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_ObjCmdProc TestmainthreadCmd; static Tcl_ObjCmdProc TestsetmainloopCmd; static Tcl_ObjCmdProc TestexitmainloopCmd; static Tcl_ObjCmdProc TestpanicCmd; static Tcl_ObjCmdProc TestparseargsCmd; static Tcl_ObjCmdProc TestparserCmd; static Tcl_ObjCmdProc TestparsevarCmd; static Tcl_ObjCmdProc TestparsevarnameCmd; static Tcl_ObjCmdProc TestpreferstableCmd; static Tcl_ObjCmdProc TestprintCmd; static Tcl_ObjCmdProc TestregexpCmd; static Tcl_ObjCmdProc TestreturnCmd; static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); static Tcl_ObjCmdProc TestsetassocdataCmd; static Tcl_ObjCmdProc TestsetCmd; static Tcl_ObjCmdProc Testset2Cmd; static Tcl_ObjCmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_ObjCmdProc TestsetplatformCmd; static Tcl_ObjCmdProc TestSizeCmd; static Tcl_ObjCmdProc TeststaticlibraryCmd; static Tcl_ObjCmdProc TesttranslatefilenameCmd; static Tcl_ObjCmdProc TestfstildeexpandCmd; static Tcl_ObjCmdProc TestupvarCmd; static Tcl_ObjCmdProc2 TestWrongNumArgsCmd; static Tcl_ObjCmdProc TestGetIndexFromObjStructCmd; static Tcl_ObjCmdProc TestChannelCmd; static Tcl_ObjCmdProc TestChannelEventCmd; static Tcl_ObjCmdProc TestSocketCmd; static Tcl_ObjCmdProc TestFilesystemCmd; static Tcl_ObjCmdProc TestSimpleFilesystemCmd; 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; |
| ︙ | ︙ | |||
313 314 315 316 317 318 319 | static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet; static Tcl_FSUtimeProc TestReportUtime; static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; | | < | | 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 |
static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet;
static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet;
static Tcl_FSUtimeProc TestReportUtime;
static Tcl_FSNormalizePathProc TestReportNormalizePath;
static Tcl_FSPathInFilesystemProc TestReportInFilesystem;
static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep;
static Tcl_FSDupInternalRepProc TestReportDupInternalRep;
static Tcl_ObjCmdProc TestServiceModeCmd;
static Tcl_FSStatProc SimpleStat;
static Tcl_FSAccessProc SimpleAccess;
static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel;
static Tcl_FSListVolumesProc SimpleListVolumes;
static Tcl_FSPathInFilesystemProc SimplePathInFilesystem;
static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr);
static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
static Tcl_ObjCmdProc TestUtfNextCmd;
static Tcl_ObjCmdProc TestUtfPrevCmd;
static Tcl_ObjCmdProc TestNumUtfCharsCmd;
static Tcl_ObjCmdProc TestGetUniCharCmd;
static Tcl_ObjCmdProc TestFindFirstCmd;
static Tcl_ObjCmdProc TestFindLastCmd;
static Tcl_ObjCmdProc TestHashSystemHashCmd;
static Tcl_ObjCmdProc TestGetIntForIndexCmd;
static Tcl_ObjCmdProc TestLutilCmd;
static Tcl_NRPostProc NREUnwind_callback;
static Tcl_ObjCmdProc TestNREUnwind;
static Tcl_ObjCmdProc TestNRELevels;
static Tcl_ObjCmdProc TestInterpResolverCmd;
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
static Tcl_ObjCmdProc TestcpuidCmd;
#endif
static Tcl_ObjCmdProc TestApplyLambdaCmd;
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
TestReportInFilesystem, /* path in */
TestReportDupInternalRep,
|
| ︙ | ︙ | |||
530 531 532 533 534 535 536 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
| < < < < < | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
#if TCL_MAJOR_VERSION > 8
if (info.isNativeObjectProc == 2) {
|
| ︙ | ︙ | |||
557 558 559 560 561 562 563 |
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | > > | | | | | | 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 |
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesCmd, NULL, NULL);
Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
TestGetIndexFromObjStructCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testasync", TestasyncCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbumpinterpepoch",
TestbumpinterpepochCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testchannel", TestChannelCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testchannelevent", TestChannelEventCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL,
NULL);
Tcl_CreateObjCommand2(interp, "testcmdobj2", Testcmdobj2Cmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testcmdtrace", TestcmdtraceCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testconcatobj", TestconcatobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testcreatecommand", TestcreatecommandCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testdcall", TestdcallCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testdel", TestdelCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testdelassocdata", TestdelassocdataCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsCmd,
NULL, NULL);
Tcl_DStringInit(&dstring);
Tcl_CreateObjCommand(interp, "testdstring", TestdstringCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testencoding", TestencodingCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testevalex", TestevalexCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testevent", TesteventCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexithandler", TestexithandlerCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprlong", TestexprlongCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprdouble", TestexprdoubleCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexprstring", TestexprstringCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfevent", TestfeventCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testhashsystemhash",
TestHashSystemHashCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetassocdata", TestgetassocdataCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetint", TestgetintCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testlongsize", TestlongsizeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetplatform", TestgetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testprint", TestprintCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testservicemode", TestServiceModeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testseterr", TestsetCmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateObjCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateObjCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testutfnext",
TestUtfNextCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testutfprev",
TestUtfPrevCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetunichar",
TestGetUniCharCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetintforindex",
TestGetIntForIndexCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsize", TestSizeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsocket", TestSocketCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "teststaticlibrary", TeststaticlibraryCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfstildeexpand",
TestfstildeexpandCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "testsetmainloop", TestsetmainloopCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testexitmainloop", TestexitmainloopCmd,
NULL, NULL);
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
NULL, NULL);
#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", TestApplyLambdaCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
*----------------------------------------------------------------------
*/
static int
TestasyncCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestasyncCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
asyncPtr = (TestAsyncHandler *)Tcl_Alloc(sizeof(TestAsyncHandler));
asyncPtr->command = (char *)Tcl_Alloc(strlen(Tcl_GetString(objv[2])) + 1);
strcpy(asyncPtr->command, Tcl_GetString(objv[2]));
Tcl_MutexLock(&asyncTestMutex);
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, INT2PTR(asyncPtr->id));
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(asyncPtr->id));
} else if (strcmp(Tcl_GetString(objv[1]), "delete") == 0) {
if (objc == 2) {
Tcl_MutexLock(&asyncTestMutex);
while (firstHandler != NULL) {
asyncPtr = firstHandler;
firstHandler = asyncPtr->nextPtr;
Tcl_AsyncDelete(asyncPtr->handler);
Tcl_Free(asyncPtr->command);
Tcl_Free(asyncPtr);
}
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_OK;
}
if (objc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
Tcl_MutexLock(&asyncTestMutex);
for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id != id) {
continue;
}
if (prevPtr == NULL) {
firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
Tcl_AsyncDelete(asyncPtr->handler);
Tcl_Free(asyncPtr->command);
Tcl_Free(asyncPtr);
break;
}
Tcl_MutexUnlock(&asyncTestMutex);
} else if (strcmp(Tcl_GetString(objv[1]), "mark") == 0) {
if (objc != 5) {
goto wrongNumArgs;
}
if ((Tcl_GetIntFromObj(interp, objv[2], &id) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[4], &code) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_SetObjResult(interp, objv[3]);
Tcl_MutexUnlock(&asyncTestMutex);
return code;
} else if (strcmp(Tcl_GetString(objv[1]), "marklater") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_ThreadId threadID;
if (Tcl_CreateThread(&threadID, AsyncThreadProc,
INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
Tcl_AppendResult(interp, "cannot create thread", (char *)NULL);
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_ERROR;
}
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be create, delete, int, mark, or marklater", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
AsyncHandlerProc(
void *clientData, /* If of TestAsyncHandler structure.
* in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
int code) /* Current return code from command. */
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
const char *listArgv[4];
char *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
if (!asyncPtr) {
/* Woops - this one was deleted between the AsyncMark and now */
return TCL_OK;
}
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetStringResult(interp);
listArgv[2] = string;
listArgv[3] = NULL;
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 |
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
Tcl_Sleep(1);
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
| | | | | | | | | | | | 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 |
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
Tcl_Sleep(1);
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
static int
TestbumpinterpepochCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *)interp;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
iPtr->compileEpoch++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Testcmdobj2 --
*
* Mock up to test the Tcl_CreateObjCommand2 functionality
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result to number of arguments, first arg, last arg.
*
*----------------------------------------------------------------------
*/
static int
Testcmdobj2Cmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultObj;
resultObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewWideIntObj(objc));
if (objc > 1) {
Tcl_ListObjAppendElement(interp, resultObj, objv[1]);
Tcl_ListObjAppendElement(interp, resultObj, objv[objc-1]);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
*
* This procedure implements the "testcmdinfo" command. It is used to
* test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation and
* deletion.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
static int
TestcmdinfoCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const subcmds[] = {
"call", "call2", "create", "delete", "get", "modify", NULL
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
case CMDINFO_DELETE:
Tcl_DStringInit(&delString);
Tcl_DeleteCommand(interp, Tcl_GetString(objv[2]));
Tcl_DStringResult(interp, &delString);
break;
case CMDINFO_GET:
if (Tcl_GetCommandInfo(interp, Tcl_GetString(objv[2]), &info) ==0) {
| | | | | | | | | | | | | 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 |
case CMDINFO_DELETE:
Tcl_DStringInit(&delString);
Tcl_DeleteCommand(interp, Tcl_GetString(objv[2]));
Tcl_DStringResult(interp, &delString);
break;
case CMDINFO_GET:
if (Tcl_GetCommandInfo(interp, Tcl_GetString(objv[2]), &info) ==0) {
Tcl_AppendResult(interp, "??", (char *)NULL);
return TCL_OK;
}
if (info.proc == CmdProc1) {
Tcl_AppendResult(interp, "CmdProc1", " ",
(char *)info.clientData, (char *)NULL);
} else if (info.proc == CmdProc2) {
Tcl_AppendResult(interp, "CmdProc2", " ",
(char *)info.clientData, (char *)NULL);
} else {
Tcl_AppendResult(interp, "unknown", (char *)NULL);
}
if (info.deleteProc == CmdDelProc1) {
Tcl_AppendResult(interp, " CmdDelProc1", " ",
(char *)info.deleteData, (char *)NULL);
} else if (info.deleteProc == CmdDelProc2) {
Tcl_AppendResult(interp, " CmdDelProc2", " ",
(char *)info.deleteData, (char *)NULL);
} else {
Tcl_AppendResult(interp, " unknown", (char *)NULL);
}
Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, (char *)NULL);
if (info.isNativeObjectProc == 0) {
Tcl_AppendResult(interp, " stringProc", (char *)NULL);
} else if (info.isNativeObjectProc == 1) {
Tcl_AppendResult(interp, " nativeObjectProc", (char *)NULL);
} else if (info.isNativeObjectProc == 2) {
Tcl_AppendResult(interp, " nativeObjectProc2", (char *)NULL);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid isNativeObjectProc value %d",
info.isNativeObjectProc));
return TCL_ERROR;
}
break;
case CMDINFO_MODIFY:
|
| ︙ | ︙ | |||
1229 1230 1231 1232 1233 1234 1235 |
return TCL_OK;
}
static int
CmdProc0(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
| | | | | | | 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 |
return TCL_OK;
}
static int
CmdProc0(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData;
Tcl_AppendResult(interp, "CmdProc1 ", refPtr->value, (char *)NULL);
return TCL_OK;
}
static int
CmdProc1(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *)clientData, (char *)NULL);
return TCL_OK;
}
static int
CmdProc2(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_AppendResult(interp, "CmdProc2 ", (char *)clientData, (char *)NULL);
return TCL_OK;
}
static void
CmdDelProc0(
void *clientData) /* String to save. */
{
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 |
static void
CmdDelProc1(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
| | | | 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 |
static void
CmdDelProc1(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
Tcl_DStringAppend(&delString, (char *)clientData, -1);
}
static void
CmdDelProc2(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
Tcl_DStringAppend(&delString, (char *)clientData, -1);
}
/*
*----------------------------------------------------------------------
*
* TestcmdtokenCmd --
*
|
| ︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 |
*----------------------------------------------------------------------
*/
static int
TestcmdtokenCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | | | | | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestcmdtokenCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
TestCommandTokenRef *refPtr;
int id;
char buf[30];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef));
refPtr->token = Tcl_CreateObjCommand(interp, Tcl_GetString(objv[2]), CmdProc0,
refPtr, CmdDelProc0);
refPtr->id = nextCommandTokenRefId;
refPtr->value = "original";
nextCommandTokenRefId++;
refPtr->nextPtr = firstCommandTokenRef;
firstCommandTokenRef = refPtr;
snprintf(buf, sizeof(buf), "%d", refPtr->id);
Tcl_AppendResult(interp, buf, (char *)NULL);
} else {
if (sscanf(Tcl_GetString(objv[2]), "%d", &id) != 1) {
Tcl_AppendResult(interp, "bad command token \"", Tcl_GetString(objv[2]),
"\"", (char *)NULL);
return TCL_ERROR;
}
for (refPtr = firstCommandTokenRef; refPtr != NULL;
refPtr = refPtr->nextPtr) {
if (refPtr->id == id) {
break;
}
}
if (refPtr == NULL) {
Tcl_AppendResult(interp, "bad command token \"", Tcl_GetString(objv[2]),
"\"", (char *)NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "name") == 0) {
Tcl_Obj *objPtr;
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, refPtr->token, objPtr);
Tcl_AppendElement(interp,
Tcl_GetCommandName(interp, refPtr->token));
Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be create, name, or free", (char *)NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1405 1406 1407 1408 1409 1410 1411 |
*----------------------------------------------------------------------
*/
static int
TestcmdtraceCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | > | | | < | | > | | | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 |
*----------------------------------------------------------------------
*/
static int
TestcmdtraceCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_DString buffer;
int result;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option script");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateObjTrace(interp, 50000, 0, CmdTraceProc, &buffer, NULL);
result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (char *)NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
} else if (strcmp(Tcl_GetString(objv[1]), "deletetest") == 0) {
/*
* Create a command trace then eval a script to check whether it is
* called. Note that this trace procedure removes itself as a further
* check of the robustness of the trace proc calling code in
* TclNRExecuteByteCode.
*/
cmdTrace = Tcl_CreateObjTrace(interp, 50000, 0, CmdTraceDeleteProc, NULL, NULL);
Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
} else if (strcmp(Tcl_GetString(objv[1]), "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateObjTrace(interp, iPtr->numLevels + 4, 0, CmdTraceProc,
&buffer, NULL);
result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (char *)NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
} else if (strcmp(Tcl_GetString(objv[1]), "resulttest") == 0) {
/* Create an object-based trace, then eval a script. This is used
* to test return codes other than TCL_OK from the trace engine.
*/
static int deleteCalled;
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, TraceProc,
&deleteCalled, ObjTraceDeleteProc);
result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
Tcl_AppendResult(interp, "Delete wasn't called", (char *)NULL);
return TCL_ERROR;
} else {
return result;
}
} else if (strcmp(Tcl_GetString(objv[1]), "doubletest") == 0) {
Tcl_Trace t1, t2;
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateObjTrace(interp, 1, 0, CmdTraceProc, &buffer, NULL);
t2 = Tcl_CreateObjTrace(interp, 50000, 0, CmdTraceProc, &buffer, NULL);
result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (char *)NULL);
}
Tcl_DeleteTrace(interp, t2);
Tcl_DeleteTrace(interp, t1);
Tcl_DStringFree(&buffer);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be tracetest, deletetest, doubletest or resulttest", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
CmdTraceProc(
void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*level*/,
const char *command, /* The command being traced (after
* substitutions). */
TCL_UNUSED(Tcl_Command) /*cmdProc*/,
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
Tcl_DString *bufPtr = (Tcl_DString *) clientData;
int i;
Tcl_DStringAppendElement(bufPtr, command);
Tcl_DStringStartSublist(bufPtr);
for (i = 0; i < objc; i++) {
Tcl_DStringAppendElement(bufPtr, Tcl_GetString(objv[i]));
}
Tcl_DStringEndSublist(bufPtr);
return TCL_OK;
}
static int
CmdTraceDeleteProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*level*/,
TCL_UNUSED(const char *) /*command*/,
TCL_UNUSED(Tcl_Command),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
/*
* Remove ourselves to test whether calling Tcl_DeleteTrace within a trace
* callback causes the for loop in TclNRExecuteByteCode that calls traces to
* reference freed memory.
*/
Tcl_DeleteTrace(interp, cmdTrace);
return TCL_OK;
}
static int
TraceProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
TCL_UNUSED(int) /*level*/,
const char *command,
TCL_UNUSED(Tcl_Command),
TCL_UNUSED(int) /*objc*/,
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *word = Tcl_GetString(objv[0]);
if (!strcmp(word, "Error")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
return TCL_ERROR;
|
| ︙ | ︙ | |||
1597 1598 1599 1600 1601 1602 1603 |
*----------------------------------------------------------------------
*/
static int
TestcreatecommandCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | | | | | | | | | | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestcreatecommandCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
Tcl_CreateObjCommand(interp, "test_ns_basic::createdcommand",
CreatedCommandProc, NULL, NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "delete") == 0) {
Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand");
} else if (strcmp(Tcl_GetString(objv[1]), "create2") == 0) {
Tcl_CreateObjCommand(interp, "value:at:",
CreatedCommandProc2, NULL, NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "delete2") == 0) {
Tcl_DeleteCommand(interp, "value:at:");
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be create, delete, create2, or delete2", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
&info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",
(char *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, (char *)NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "value:at:", &info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
(char *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc2 in ",
info.namespacePtr->fullName, (char *)NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestdcallCmd --
|
| ︙ | ︙ | |||
1687 1688 1689 1690 1691 1692 1693 |
*----------------------------------------------------------------------
*/
static int
TestdcallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | > | | | 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 |
*----------------------------------------------------------------------
*/
static int
TestdcallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int i;
int id;
delInterp = Tcl_CreateInterp();
Tcl_DStringInit(&delString);
for (i = 1; i < objc; i++) {
if (Tcl_GetIntFromObj(interp, objv[i], &id) != TCL_OK) {
return TCL_ERROR;
}
if (id < 0) {
Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
INT2PTR(-id));
} else {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
|
| ︙ | ︙ | |||
1751 1752 1753 1754 1755 1756 1757 |
*----------------------------------------------------------------------
*/
static int
TestdelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | | | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestdelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
DelCmd *dPtr;
Tcl_Interp *child;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "interp name delcmdname");
return TCL_ERROR;
}
child = Tcl_GetChild(interp, Tcl_GetString(objv[1]));
if (child == NULL) {
return TCL_ERROR;
}
dPtr = (DelCmd *)Tcl_Alloc(sizeof(DelCmd));
dPtr->interp = interp;
dPtr->deleteCmd = (char *)Tcl_Alloc(strlen(Tcl_GetString(objv[3])) + 1);
strcpy(dPtr->deleteCmd, Tcl_GetString(objv[3]));
Tcl_CreateObjCommand(child, Tcl_GetString(objv[2]), DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(
void *clientData, /* String result to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objv*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
DelCmd *dPtr = (DelCmd *) clientData;
Tcl_AppendResult(interp, dPtr->deleteCmd, (char *)NULL);
Tcl_Free(dPtr->deleteCmd);
Tcl_Free(dPtr);
return TCL_OK;
}
static void
DelDeleteProc(
|
| ︙ | ︙ | |||
1826 1827 1828 1829 1830 1831 1832 |
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 |
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "data_key");
return TCL_ERROR;
}
Tcl_DeleteAssocData(interp, Tcl_GetString(objv[1]));
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* TestdoubledigitsCmd --
|
| ︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 | * type - One of 'shortest', 'e', 'f' * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int | | | 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 |
* type - One of 'shortest', 'e', 'f'
* shorten - Indicates that the 'shorten' flag should be passed in.
*
*-----------------------------------------------------------------------------
*/
static int
TestdoubledigitsCmd(
TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj* const objv[]) /* Parameter vector */
{
static const char *options[] = {
"shortest",
|
| ︙ | ︙ | |||
1904 1905 1906 1907 1908 1909 1910 |
if (Tcl_FetchInternalRep(objv[1], doubleType)
&& isnan(objv[1]->internalRep.doubleValue)) {
status = TCL_OK;
memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double));
}
}
if (status != TCL_OK
| | | | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 |
if (Tcl_FetchInternalRep(objv[1], doubleType)
&& isnan(objv[1]->internalRep.doubleValue)) {
status = TCL_OK;
memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double));
}
}
if (status != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK
|| Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type",
TCL_EXACT, &type) != TCL_OK) {
fprintf(stderr, "bad value? %g\n", d);
return TCL_ERROR;
}
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
|
| ︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 |
*----------------------------------------------------------------------
*/
static int
TestdstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestdstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int count;
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "append") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringAppend(&dstring, Tcl_GetString(objv[2]), count);
} else if (strcmp(Tcl_GetString(objv[1]), "element") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_DStringAppendElement(&dstring, Tcl_GetString(objv[2]));
} else if (strcmp(Tcl_GetString(objv[1]), "end") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
Tcl_DStringEndSublist(&dstring);
} else if (strcmp(Tcl_GetString(objv[1]), "free") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
Tcl_DStringFree(&dstring);
} else if (strcmp(Tcl_GetString(objv[1]), "get") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE);
} else if (strcmp(Tcl_GetString(objv[1]), "gresult") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (strcmp(Tcl_GetString(objv[2]), "staticsmall") == 0) {
Tcl_AppendResult(interp, "short", (char *)NULL);
} else if (strcmp(Tcl_GetString(objv[2]), "staticlarge") == 0) {
Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", (char *)NULL);
} else if (strcmp(Tcl_GetString(objv[2]), "free") == 0) {
char *s = (char *)Tcl_Alloc(100);
strcpy(s, "This is a malloc-ed string");
Tcl_SetResult(interp, s, TCL_DYNAMIC);
} else if (strcmp(Tcl_GetString(objv[2]), "special") == 0) {
char *s = (char *)Tcl_Alloc(100) + 16;
strcpy(s, "This is a specially-allocated string");
Tcl_SetResult(interp, s, SpecialFree);
} else {
Tcl_AppendResult(interp, "bad gresult option \"", Tcl_GetString(objv[2]),
"\": must be staticsmall, staticlarge, free, or special",
(char *)NULL);
return TCL_ERROR;
}
Tcl_DStringGetResult(interp, &dstring);
} else if (strcmp(Tcl_GetString(objv[1]), "length") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_DStringLength(&dstring)));
} else if (strcmp(Tcl_GetString(objv[1]), "result") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
Tcl_DStringResult(interp, &dstring);
} else if (strcmp(Tcl_GetString(objv[1]), "toobj") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
Tcl_SetObjResult(interp, Tcl_DStringToObj(&dstring));
} else if (strcmp(Tcl_GetString(objv[1]), "trunc") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[2], &count) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringSetLength(&dstring, count);
} else if (strcmp(Tcl_GetString(objv[1]), "start") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
Tcl_DStringStartSublist(&dstring);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be append, element, end, free, get, gresult, length, "
"result, start, toobj, or trunc", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
* The procedure below is used as a special freeProc to test how well
|
| ︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 | * UtfTransformFn -- * * Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf * as otherwise there is no script level command that directly exercises * these functions (i/o command cannot test all combinations) * The arguments at the script level are roughly those of the above * functions: | | | | | < | | > | > | 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 |
* UtfTransformFn --
*
* Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf
* as otherwise there is no script level command that directly exercises
* these functions (i/o command cannot test all combinations)
* The arguments at the script level are roughly those of the above
* functions:
* encodingname srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar?
*
* Results:
* TCL_OK or TCL_ERROR. This indicates any errors running the test, NOT the
* result of Tcl_UtfToExternal or Tcl_ExternalToUtf.
*
* Side effects:
*
* The result in the interpreter is a list of the return code from the
* Tcl_UtfToExternal/Tcl_ExternalToUtf functions, the encoding state, and
* an encoded binary string of length dstLen. Note the string is the
* entire output buffer, not just the part containing the decoded
* portion. This allows for additional checks at test script level.
*
* If any of the srcreadvar, dstwrotevar and dstcharsvar are specified and
* not empty, they are treated as names of variables where the *srcRead,
* *dstWrote and *dstChars output from the functions are stored.
*
* The function also checks internally whether nuls are correctly
* appended as requested but the TCL_ENCODING_NO_TERMINATE flag
* and that no buffer overflows occur.
*------------------------------------------------------------------------
*/
typedef int
UtfTransformFn(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src,
Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst,
Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr);
static int UtfExtWrapper(
Tcl_Interp *interp, UtfTransformFn *transformer, int objc, Tcl_Obj *const objv[])
{
Tcl_Encoding encoding;
Tcl_EncodingState encState, *encStatePtr;
Tcl_Size srcLen, bufLen;
const unsigned char *bytes;
|
| ︙ | ︙ | |||
2123 2124 2125 2126 2127 2128 2129 |
const char *flagKey;
int flag;
} flagMap[] = {
{"start", TCL_ENCODING_START},
{"end", TCL_ENCODING_END},
{"noterminate", TCL_ENCODING_NO_TERMINATE},
{"charlimit", TCL_ENCODING_CHAR_LIMIT},
| | | | | < < | | | | < < < < < | | | | | | | | | | | | 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 |
const char *flagKey;
int flag;
} flagMap[] = {
{"start", TCL_ENCODING_START},
{"end", TCL_ENCODING_END},
{"noterminate", TCL_ENCODING_NO_TERMINATE},
{"charlimit", TCL_ENCODING_CHAR_LIMIT},
{"tcl8", TCL_ENCODING_PROFILE_TCL8},
{"strict", TCL_ENCODING_PROFILE_STRICT},
{"replace", TCL_ENCODING_PROFILE_REPLACE},
{NULL, 0}
};
Tcl_Size i;
Tcl_WideInt wide;
if (objc < 7 || objc > 10) {
Tcl_WrongNumArgs(interp, 2, objv,
"encoding srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar?");
return TCL_ERROR;
}
if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) {
return TCL_ERROR;
}
/* Flags may be specified as list of integers and keywords */
flags = 0;
if (Tcl_ListObjGetElements(interp, objv[4], &nflags, &flagObjs) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < nflags; ++i) {
int flag;
if (Tcl_GetIntFromObj(NULL, flagObjs[i], &flag) == TCL_OK) {
flags |= flag;
} else {
int idx;
if (Tcl_GetIndexFromObjStruct(interp, flagObjs[i], flagMap, sizeof(flagMap[0]),
"flag", 0, &idx) != TCL_OK) {
return TCL_ERROR;
}
flags |= flagMap[idx].flag;
}
}
/* Assumes state is integer if not "" */
if (Tcl_GetWideIntFromObj(interp, objv[5], &wide) == TCL_OK) {
encState = (Tcl_EncodingState)(size_t)wide;
encStatePtr = &encState;
} else if (Tcl_GetCharLength(objv[5]) == 0) {
encStatePtr = NULL;
} else {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[6], &dstLen) != TCL_OK) {
return TCL_ERROR;
}
srcReadVar = NULL;
dstWroteVar = NULL;
dstCharsVar = NULL;
if (objc > 7) {
/* Has caller requested srcRead? */
if (Tcl_GetCharLength(objv[7])) {
srcReadVar = objv[7];
}
if (objc > 8) {
/* Ditto for dstWrote */
if (Tcl_GetCharLength(objv[8])) {
dstWroteVar = objv[8];
}
if (objc > 9) {
if (Tcl_GetCharLength(objv[9])) {
dstCharsVar = objv[9];
}
}
}
}
if (flags & TCL_ENCODING_CHAR_LIMIT) {
/* Caller should have specified the dest char limit */
Tcl_Obj *valueObj;
|
| ︙ | ︙ | |||
2224 2225 2226 2227 2228 2229 2230 |
bufLen = dstLen + 4; /* 4 -> overflow detection */
bufPtr = (unsigned char *) Tcl_Alloc(bufLen);
memset(bufPtr, 0xFF, dstLen); /* Need to check nul terminator */
memmove(bufPtr + dstLen, "\xAB\xCD\xEF\xAB", 4); /* overflow detection */
bytes = Tcl_GetByteArrayFromObj(objv[3], &srcLen); /* Last! to avoid shimmering */
result = (*transformer)(interp, encoding, (const char *)bytes, srcLen, flags,
| | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | | | < < < | | | < < < | | | 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 2265 2266 2267 2268 2269 2270 |
bufLen = dstLen + 4; /* 4 -> overflow detection */
bufPtr = (unsigned char *) Tcl_Alloc(bufLen);
memset(bufPtr, 0xFF, dstLen); /* Need to check nul terminator */
memmove(bufPtr + dstLen, "\xAB\xCD\xEF\xAB", 4); /* overflow detection */
bytes = Tcl_GetByteArrayFromObj(objv[3], &srcLen); /* Last! to avoid shimmering */
result = (*transformer)(interp, encoding, (const char *)bytes, srcLen, flags,
encStatePtr, (char *)bufPtr, dstLen,
srcReadVar ? &srcRead : NULL,
&dstWrote,
dstCharsVar ? &dstChars : NULL);
if (memcmp(bufPtr + bufLen - 4, "\xAB\xCD\xEF\xAB", 4)) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("%s wrote past output buffer",
transformer == Tcl_ExternalToUtf ?
"Tcl_ExternalToUtf" : "Tcl_UtfToExternal"));
result = TCL_ERROR;
} else if (result != TCL_ERROR) {
Tcl_Obj *resultObjs[3];
switch (result) {
case TCL_OK:
resultObjs[0] = Tcl_NewStringObj("ok", TCL_INDEX_NONE);
break;
case TCL_CONVERT_MULTIBYTE:
resultObjs[0] = Tcl_NewStringObj("multibyte", TCL_INDEX_NONE);
break;
case TCL_CONVERT_SYNTAX:
resultObjs[0] = Tcl_NewStringObj("syntax", TCL_INDEX_NONE);
break;
case TCL_CONVERT_UNKNOWN:
resultObjs[0] = Tcl_NewStringObj("unknown", TCL_INDEX_NONE);
break;
case TCL_CONVERT_NOSPACE:
resultObjs[0] = Tcl_NewStringObj("nospace", TCL_INDEX_NONE);
break;
default:
resultObjs[0] = Tcl_NewIntObj(result);
break;
}
result = TCL_OK;
resultObjs[1] =
encStatePtr ? Tcl_NewWideIntObj((Tcl_WideInt)(size_t)encState) : Tcl_NewObj();
resultObjs[2] = Tcl_NewByteArrayObj(bufPtr, dstLen);
if (srcReadVar) {
if (Tcl_ObjSetVar2(interp, srcReadVar, NULL, Tcl_NewIntObj(srcRead),
TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
}
}
if (dstWroteVar) {
if (Tcl_ObjSetVar2(interp, dstWroteVar, NULL, Tcl_NewIntObj(dstWrote),
TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
}
}
if (dstCharsVar) {
if (Tcl_ObjSetVar2(interp, dstCharsVar, NULL, Tcl_NewIntObj(dstChars),
TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewListObj(3, resultObjs));
}
Tcl_Free(bufPtr);
Tcl_FreeEncoding(encoding); /* Free returned reference */
return result;
}
|
| ︙ | ︙ | |||
2312 2313 2314 2315 2316 2317 2318 | * Side effects: * Load encodings. * *---------------------------------------------------------------------- */ static int | | | 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 |
* Side effects:
* Load encodings.
*
*----------------------------------------------------------------------
*/
static int
TestencodingCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Encoding encoding;
Tcl_Size length;
|
| ︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 |
}
encoding =
Tcl_GetEncoding(interp, objc == 2 ? NULL : Tcl_GetString(objv[2]));
if (encoding == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
| | | | | | 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 |
}
encoding =
Tcl_GetEncoding(interp, objc == 2 ? NULL : Tcl_GetString(objv[2]));
if (encoding == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
Tcl_NewIntObj(Tcl_GetEncodingNulLength(encoding)));
Tcl_FreeEncoding(encoding);
break;
case ENC_EXTTOUTF:
return UtfExtWrapper(interp,Tcl_ExternalToUtf,objc,objv);
case ENC_UTFTOEXT:
return UtfExtWrapper(interp,Tcl_UtfToExternal,objc,objv);
}
return TCL_OK;
}
static int
EncodingToUtfProc(
void *clientData, /* TclEncoding structure. */
|
| ︙ | ︙ | |||
2482 2483 2484 2485 2486 2487 2488 |
Tcl_Free(encodingPtr->fromUtfCmd);
Tcl_Free(encodingPtr);
}
/*
*----------------------------------------------------------------------
*
| | | | | | | 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 |
Tcl_Free(encodingPtr->fromUtfCmd);
Tcl_Free(encodingPtr);
}
/*
*----------------------------------------------------------------------
*
* TestevalexCmd --
*
* This procedure implements the "testevalex" command. It is
* used to test Tcl_EvalEx.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalexCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags;
Tcl_Size length;
const char *script;
flags = 0;
if (objc == 3) {
const char *global = Tcl_GetString(objv[2]);
if (strcmp(global, "global") != 0) {
Tcl_AppendResult(interp, "bad value \"", global,
"\": must be global", (char *)NULL);
return TCL_ERROR;
}
flags = TCL_EVAL_GLOBAL;
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &length);
return Tcl_EvalEx(interp, script, length, flags);
}
/*
*----------------------------------------------------------------------
*
* TestevalobjvCmd --
*
* This procedure implements the "testevalobjv" command. It is
* used to test Tcl_EvalObjv.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalobjvCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int evalGlobal;
|
| ︙ | ︙ | |||
2565 2566 2567 2568 2569 2570 2571 |
return Tcl_EvalObjv(interp, objc-2, objv+2,
(evalGlobal) ? TCL_EVAL_GLOBAL : 0);
}
/*
*----------------------------------------------------------------------
*
| | | 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 |
return Tcl_EvalObjv(interp, objc-2, objv+2,
(evalGlobal) ? TCL_EVAL_GLOBAL : 0);
}
/*
*----------------------------------------------------------------------
*
* TesteventCmd --
*
* This procedure implements a 'testevent' command. The command
* is used to test event queue management.
*
* The command takes two forms:
* - testevent queue name position script
* Queues an event at the given position in the queue, and
|
| ︙ | ︙ | |||
2592 2593 2594 2595 2596 2597 2598 | * Side effects: * Manipulates the event queue as directed. * *---------------------------------------------------------------------- */ static int | | | 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 |
* Side effects:
* Manipulates the event queue as directed.
*
*----------------------------------------------------------------------
*/
static int
TesteventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
static const char *const subcommands[] = { /* Possible subcommands */
"queue", "delete", NULL
|
| ︙ | ︙ | |||
2741 2742 2743 2744 2745 2746 2747 |
Tcl_Obj *targetName; /* Name of the event(s) to delete */
const char *targetNameStr;
if (event->proc != TesteventProc) {
return 0;
}
targetName = (Tcl_Obj *) clientData;
| | | 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 |
Tcl_Obj *targetName; /* Name of the event(s) to delete */
const char *targetNameStr;
if (event->proc != TesteventProc) {
return 0;
}
targetName = (Tcl_Obj *) clientData;
targetNameStr = (char *)Tcl_GetString(targetName);
ev = (TestEvent *) event;
evNameStr = Tcl_GetString(ev->tag);
if (strcmp(evNameStr, targetNameStr) == 0) {
Tcl_DecrRefCount(ev->tag);
Tcl_DecrRefCount(ev->command);
return 1;
} else {
|
| ︙ | ︙ | |||
2774 2775 2776 2777 2778 2779 2780 |
*----------------------------------------------------------------------
*/
static int
TestexithandlerCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestexithandlerCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int value;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "create|delete value");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
INT2PTR(value));
} else if (strcmp(Tcl_GetString(objv[1]), "delete") == 0) {
Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
INT2PTR(value));
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be create or delete", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
ExitProcOdd(
|
| ︙ | ︙ | |||
2850 2851 2852 2853 2854 2855 2856 |
*----------------------------------------------------------------------
*/
static int
TestexprlongCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | | 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 |
*----------------------------------------------------------------------
*/
static int
TestexprlongCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
Tcl_AppendResult(interp, "This is a result", (char *)NULL);
result = Tcl_ExprLong(interp, Tcl_GetString(objv[1]), &exprResult);
if (result != TCL_OK) {
return result;
}
snprintf(buf, sizeof(buf), ": %ld", exprResult);
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprlongobjCmd --
|
| ︙ | ︙ | |||
2904 2905 2906 2907 2908 2909 2910 |
char buf[4 + TCL_INTEGER_SPACE];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
| | | | 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 |
char buf[4 + TCL_INTEGER_SPACE];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
Tcl_AppendResult(interp, "This is a result", (char *)NULL);
result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
}
snprintf(buf, sizeof(buf), ": %ld", exprResult);
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprdoubleCmd --
|
| ︙ | ︙ | |||
2935 2936 2937 2938 2939 2940 2941 |
*----------------------------------------------------------------------
*/
static int
TestexprdoubleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | | 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 |
*----------------------------------------------------------------------
*/
static int
TestexprdoubleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
double exprResult;
char buf[4 + TCL_DOUBLE_SPACE];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
Tcl_AppendResult(interp, "This is a result", (char *)NULL);
result = Tcl_ExprDouble(interp, Tcl_GetString(objv[1]), &exprResult);
if (result != TCL_OK) {
return result;
}
strcpy(buf, ": ");
Tcl_PrintDouble(interp, exprResult, buf+2);
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprdoubleobjCmd --
|
| ︙ | ︙ | |||
2990 2991 2992 2993 2994 2995 2996 |
char buf[4 + TCL_DOUBLE_SPACE];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
| | | | 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 |
char buf[4 + TCL_DOUBLE_SPACE];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
Tcl_AppendResult(interp, "This is a result", (char *)NULL);
result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
}
strcpy(buf, ": ");
Tcl_PrintDouble(interp, exprResult, buf+2);
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprstringCmd --
|
| ︙ | ︙ | |||
3021 3022 3023 3024 3025 3026 3027 |
*----------------------------------------------------------------------
*/
static int
TestexprstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 |
*----------------------------------------------------------------------
*/
static int
TestexprstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
return Tcl_ExprString(interp, Tcl_GetString(objv[1]));
}
/*
*----------------------------------------------------------------------
*
* TestfilelinkCmd --
*
|
| ︙ | ︙ | |||
3075 3076 3077 3078 3079 3080 3081 |
/* Create link from source to target */
contents = Tcl_FSLink(objv[1], objv[2],
TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not create link from \"",
Tcl_GetString(objv[1]), "\" to \"",
Tcl_GetString(objv[2]), "\": ",
| | | | 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 |
/* Create link from source to target */
contents = Tcl_FSLink(objv[1], objv[2],
TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not create link from \"",
Tcl_GetString(objv[1]), "\" to \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *)NULL);
return TCL_ERROR;
}
} else {
/* Read link */
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not read link \"",
Tcl_GetString(objv[1]), "\": ",
Tcl_PosixError(interp), (char *)NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 2) {
/*
* If we are creating a link, this will actually just
|
| ︙ | ︙ | |||
3120 3121 3122 3123 3124 3125 3126 |
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | 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 |
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
char *res;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "data_key");
return TCL_ERROR;
}
res = (char *)Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), NULL);
if (res != NULL) {
Tcl_AppendResult(interp, res, (char *)NULL);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3158 3159 3160 3161 3162 3163 3164 |
*----------------------------------------------------------------------
*/
static int
TestgetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 |
*----------------------------------------------------------------------
*/
static int
TestgetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
static const char *const platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
platform = TclGetPlatform();
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
Tcl_AppendResult(interp, platformStrings[*platform], (char *)NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestinterpdeleteCmd --
|
| ︙ | ︙ | |||
3198 3199 3200 3201 3202 3203 3204 |
*----------------------------------------------------------------------
*/
static int
TestinterpdeleteCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 |
*----------------------------------------------------------------------
*/
static int
TestinterpdeleteCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
Tcl_Interp *childToDelete;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "path");
return TCL_ERROR;
}
childToDelete = Tcl_GetChild(interp, Tcl_GetString(objv[1]));
if (childToDelete == NULL) {
return TCL_ERROR;
}
Tcl_DeleteInterp(childToDelete);
return TCL_OK;
}
|
| ︙ | ︙ | |||
3238 3239 3240 3241 3242 3243 3244 |
*----------------------------------------------------------------------
*/
static int
TestlinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | < < | | | | | | | | | | | | | | | | | | | | 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 |
*----------------------------------------------------------------------
*/
static int
TestlinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
static Tcl_WideInt wideVar = 79;
static char *stringVar = NULL;
static char charVar = '@';
static unsigned char ucharVar = 130;
static short shortVar = 3000;
static unsigned short ushortVar = 60000;
static unsigned int uintVar = 0xBEEFFEED;
static long longVar = 123456789L;
static unsigned long ulongVar = 3456789012UL;
static float floatVar = 4.5;
static Tcl_WideUInt uwideVar = 123;
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
Tcl_Obj *tmp;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg arg arg arg arg arg arg arg arg arg arg"
" arg arg?");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
if (objc != 16) {
Tcl_WrongNumArgs(interp, 2, objv, "intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO"
" ushortRO uintRO longRO ulongRO floatRO uwideRO");
return TCL_ERROR;
}
if (created) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
Tcl_UnlinkVar(interp, "wide");
Tcl_UnlinkVar(interp, "char");
Tcl_UnlinkVar(interp, "uchar");
Tcl_UnlinkVar(interp, "short");
Tcl_UnlinkVar(interp, "ushort");
Tcl_UnlinkVar(interp, "uint");
Tcl_UnlinkVar(interp, "long");
Tcl_UnlinkVar(interp, "ulong");
Tcl_UnlinkVar(interp, "float");
Tcl_UnlinkVar(interp, "uwide");
}
created = 1;
if (Tcl_GetBooleanFromObj(interp, objv[2], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "int", &intVar,
TCL_LINK_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "real", &realVar,
TCL_LINK_DOUBLE | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[4], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "bool", &boolVar,
TCL_LINK_BOOLEAN | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[5], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "string", &stringVar,
TCL_LINK_STRING | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[6], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "wide", &wideVar,
TCL_LINK_WIDE_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[7], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "char", &charVar,
TCL_LINK_CHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[8], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "uchar", &ucharVar,
TCL_LINK_UCHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[9], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "short", &shortVar,
TCL_LINK_SHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[10], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "ushort", &ushortVar,
TCL_LINK_USHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[11], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "uint", &uintVar,
TCL_LINK_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[12], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "long", &longVar,
TCL_LINK_LONG | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[13], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "ulong", &ulongVar,
TCL_LINK_ULONG | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[14], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "float", &floatVar,
TCL_LINK_FLOAT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[15], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "uwide", &uwideVar,
TCL_LINK_WIDE_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(Tcl_GetString(objv[1]), "delete") == 0) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
Tcl_UnlinkVar(interp, "wide");
Tcl_UnlinkVar(interp, "char");
Tcl_UnlinkVar(interp, "uchar");
Tcl_UnlinkVar(interp, "short");
Tcl_UnlinkVar(interp, "ushort");
Tcl_UnlinkVar(interp, "uint");
Tcl_UnlinkVar(interp, "long");
Tcl_UnlinkVar(interp, "ulong");
Tcl_UnlinkVar(interp, "float");
Tcl_UnlinkVar(interp, "uwide");
created = 0;
} else if (strcmp(Tcl_GetString(objv[1]), "get") == 0) {
TclFormatInt(buffer, intVar);
Tcl_AppendElement(interp, buffer);
Tcl_PrintDouble(NULL, realVar, buffer);
Tcl_AppendElement(interp, buffer);
TclFormatInt(buffer, boolVar);
Tcl_AppendElement(interp, buffer);
Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
|
| ︙ | ︙ | |||
3447 3448 3449 3450 3451 3452 3453 | TclFormatInt(buffer, (int) ushortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); tmp = Tcl_NewWideIntObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); | < < < < < < < < < | < < < < < < < | < | | < < | | | | > > > > > | | | < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 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 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 |
TclFormatInt(buffer, (int) ushortVar);
Tcl_AppendElement(interp, buffer);
TclFormatInt(buffer, (int) uintVar);
Tcl_AppendElement(interp, buffer);
tmp = Tcl_NewWideIntObj(longVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
tmp = Tcl_NewWideUIntObj(ulongVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
Tcl_PrintDouble(NULL, (double)floatVar, buffer);
Tcl_AppendElement(interp, buffer);
tmp = Tcl_NewWideUIntObj(uwideVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
} else if (strcmp(Tcl_GetString(objv[1]), "set") == 0) {
int v;
if (objc != 16) {
Tcl_WrongNumArgs(interp, 2, objv, "intValue realValue boolValue stringValue wideValue"
" charValue ucharValue shortValue ushortValue uintValue"
" longValue ulongValue floatValue uwideValue");
return TCL_ERROR;
}
if (Tcl_GetString(objv[2])[0] != 0) {
if (Tcl_GetIntFromObj(interp, objv[2], &intVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (Tcl_GetString(objv[3])[0] != 0) {
if (Tcl_GetDoubleFromObj(interp, objv[3], &realVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (Tcl_GetString(objv[4])[0] != 0) {
if (Tcl_GetBooleanFromObj(interp, objv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (Tcl_GetString(objv[5])[0] != 0) {
if (stringVar != NULL) {
Tcl_Free(stringVar);
}
if (strcmp(Tcl_GetString(objv[5]), "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *)Tcl_Alloc(strlen(Tcl_GetString(objv[5])) + 1);
strcpy(stringVar, Tcl_GetString(objv[5]));
}
}
if (Tcl_GetString(objv[6])[0] != 0) {
tmp = Tcl_NewStringObj(Tcl_GetString(objv[6]), -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
}
if (Tcl_GetString(objv[7])[0]) {
if (Tcl_GetIntFromObj(interp, objv[7], &v) != TCL_OK) {
return TCL_ERROR;
}
charVar = (char) v;
}
if (Tcl_GetString(objv[8])[0]) {
if (Tcl_GetIntFromObj(interp, objv[8], &v) != TCL_OK) {
return TCL_ERROR;
}
ucharVar = (unsigned char) v;
}
if (Tcl_GetString(objv[9])[0]) {
if (Tcl_GetIntFromObj(interp, objv[9], &v) != TCL_OK) {
return TCL_ERROR;
}
shortVar = (short) v;
}
if (Tcl_GetString(objv[10])[0]) {
if (Tcl_GetIntFromObj(interp, objv[10], &v) != TCL_OK) {
return TCL_ERROR;
}
ushortVar = (unsigned short) v;
}
if (Tcl_GetString(objv[11])[0]) {
if (Tcl_GetIntFromObj(interp, objv[11], &v) != TCL_OK) {
return TCL_ERROR;
}
uintVar = (unsigned int) v;
}
if (Tcl_GetString(objv[12])[0]) {
if (Tcl_GetIntFromObj(interp, objv[12], &v) != TCL_OK) {
return TCL_ERROR;
}
longVar = (long) v;
}
if (Tcl_GetString(objv[13])[0]) {
if (Tcl_GetIntFromObj(interp, objv[13], &v) != TCL_OK) {
return TCL_ERROR;
}
ulongVar = (unsigned long) v;
}
if (Tcl_GetString(objv[14])[0]) {
double d;
if (Tcl_GetDoubleFromObj(interp, objv[14], &d) != TCL_OK) {
return TCL_ERROR;
}
floatVar = (float) d;
}
if (Tcl_GetString(objv[15])[0]) {
Tcl_WideInt w;
tmp = Tcl_NewStringObj(Tcl_GetString(objv[15]), -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
uwideVar = (Tcl_WideUInt)w;
}
} else if (strcmp(Tcl_GetString(objv[1]), "update") == 0) {
int v;
if (objc != 16) {
Tcl_WrongNumArgs(interp, 2, objv, "intValue realValue boolValue stringValue wideValue"
" charValue ucharValue shortValue ushortValue uintValue"
" longValue ulongValue floatValue uwideValue");
return TCL_ERROR;
}
if (Tcl_GetString(objv[2])[0] != 0) {
if (Tcl_GetIntFromObj(interp, objv[2], &intVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "int");
}
if (Tcl_GetString(objv[3])[0] != 0) {
if (Tcl_GetDoubleFromObj(interp, objv[3], &realVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "real");
}
if (Tcl_GetString(objv[4])[0] != 0) {
if (Tcl_GetIntFromObj(interp, objv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "bool");
}
if (Tcl_GetString(objv[5])[0] != 0) {
if (stringVar != NULL) {
Tcl_Free(stringVar);
}
if (strcmp(Tcl_GetString(objv[5]), "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *)Tcl_Alloc(strlen(Tcl_GetString(objv[5])) + 1);
strcpy(stringVar, Tcl_GetString(objv[5]));
}
Tcl_UpdateLinkedVar(interp, "string");
}
if (Tcl_GetString(objv[6])[0] != 0) {
tmp = Tcl_NewStringObj(Tcl_GetString(objv[6]), -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
Tcl_UpdateLinkedVar(interp, "wide");
}
if (Tcl_GetString(objv[7])[0]) {
if (Tcl_GetIntFromObj(interp, objv[7], &v) != TCL_OK) {
return TCL_ERROR;
}
charVar = (char) v;
Tcl_UpdateLinkedVar(interp, "char");
}
if (Tcl_GetString(objv[8])[0]) {
if (Tcl_GetIntFromObj(interp, objv[8], &v) != TCL_OK) {
return TCL_ERROR;
}
ucharVar = (unsigned char) v;
Tcl_UpdateLinkedVar(interp, "uchar");
}
if (Tcl_GetString(objv[9])[0]) {
if (Tcl_GetIntFromObj(interp, objv[9], &v) != TCL_OK) {
return TCL_ERROR;
}
shortVar = (short) v;
Tcl_UpdateLinkedVar(interp, "short");
}
if (Tcl_GetString(objv[10])[0]) {
if (Tcl_GetIntFromObj(interp, objv[10], &v) != TCL_OK) {
return TCL_ERROR;
}
ushortVar = (unsigned short) v;
Tcl_UpdateLinkedVar(interp, "ushort");
}
if (Tcl_GetString(objv[11])[0]) {
if (Tcl_GetIntFromObj(interp, objv[11], &v) != TCL_OK) {
return TCL_ERROR;
}
uintVar = (unsigned int) v;
Tcl_UpdateLinkedVar(interp, "uint");
}
if (Tcl_GetString(objv[12])[0]) {
if (Tcl_GetIntFromObj(interp, objv[12], &v) != TCL_OK) {
return TCL_ERROR;
}
longVar = (long) v;
Tcl_UpdateLinkedVar(interp, "long");
}
if (Tcl_GetString(objv[13])[0]) {
if (Tcl_GetIntFromObj(interp, objv[13], &v) != TCL_OK) {
return TCL_ERROR;
}
ulongVar = (unsigned long) v;
Tcl_UpdateLinkedVar(interp, "ulong");
}
if (Tcl_GetString(objv[14])[0]) {
double d;
if (Tcl_GetDoubleFromObj(interp, objv[14], &d) != TCL_OK) {
return TCL_ERROR;
}
floatVar = (float) d;
Tcl_UpdateLinkedVar(interp, "float");
}
if (Tcl_GetString(objv[15])[0]) {
Tcl_WideInt w;
tmp = Tcl_NewStringObj(Tcl_GetString(objv[15]), -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
uwideVar = (Tcl_WideUInt)w;
Tcl_UpdateLinkedVar(interp, "uwide");
}
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": should be create, delete, get, set, or update", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3722 3723 3724 3725 3726 3727 3728 |
*
*----------------------------------------------------------------------
*/
static int
TestlinkarrayCmd(
TCL_UNUSED(void *),
| | | | | | | 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 |
*
*----------------------------------------------------------------------
*/
static int
TestlinkarrayCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *LinkOption[] = {
"update", "remove", "create", NULL
};
enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE } optionIndex;
static const char *LinkType[] = {
"char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
"wide", "uwide", "float", "double", "string", "char*", "binary", NULL
};
/* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */
static int LinkTypes[] = {
TCL_LINK_CHAR, TCL_LINK_UCHAR,
TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
TCL_LINK_BINARY
};
int typeIndex, readonly, size;
Tcl_Size i, length;
char *name, *arg;
Tcl_WideInt addr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option args");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3789 3790 3791 3792 3793 3794 3795 |
if (arg[1] != 'r') {
goto wrongArgs;
}
readonly = TCL_LINK_READ_ONLY;
i++;
}
if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
| | | | 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 |
if (arg[1] != 'r') {
goto wrongArgs;
}
readonly = TCL_LINK_READ_ONLY;
i++;
}
if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
&typeIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
return TCL_ERROR;
}
name = Tcl_GetString(objv[i++]);
/*
* If no address is given request one in the underlying function
*/
if (i < objc) {
if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong address value", -1));
return TCL_ERROR;
}
} else {
addr = 0;
}
return Tcl_LinkArray(interp, name, INT2PTR(addr),
|
| ︙ | ︙ | |||
3895 3896 3897 3898 3899 3900 3901 |
!= TCL_OK) {
return TCL_ERROR;
}
}
}
resultObj = TclListTestObj(length, leadSpace, endSpace);
if (resultObj == NULL) {
| | | 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 |
!= TCL_OK) {
return TCL_ERROR;
}
}
}
resultObj = TclListTestObj(length, leadSpace, endSpace);
if (resultObj == NULL) {
Tcl_AppendResult(interp, "List capacity exceeded", (char *)NULL);
return TCL_ERROR;
}
}
break;
case LISTREP_DESCRIBE:
#define APPEND_FIELD(targetObj_, structPtr_, fld_) \
|
| ︙ | ︙ | |||
3925 3926 3927 3928 3929 3930 3931 |
/* Force list representation */
if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
return TCL_ERROR;
}
ListObjGetRep(objv[2], &listRep);
listRepObjs[0] = Tcl_NewStringObj("store", -1);
listRepObjs[1] = Tcl_NewListObj(12, NULL);
| | | | | | < | | | < | | 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 |
/* Force list representation */
if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
return TCL_ERROR;
}
ListObjGetRep(objv[2], &listRep);
listRepObjs[0] = Tcl_NewStringObj("store", -1);
listRepObjs[1] = Tcl_NewListObj(12, NULL);
Tcl_ListObjAppendElement(interp, listRepObjs[1],
Tcl_NewStringObj("memoryAddress", -1));
Tcl_ListObjAppendElement(interp, listRepObjs[1],
Tcl_ObjPrintf("%p", listRep.storePtr));
APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
if (listRep.spanPtr) {
listRepObjs[2] = Tcl_NewStringObj("span", -1);
listRepObjs[3] = Tcl_NewListObj(8, NULL);
Tcl_ListObjAppendElement(interp, listRepObjs[3],
Tcl_NewStringObj("memoryAddress", -1));
Tcl_ListObjAppendElement(interp, listRepObjs[3],
Tcl_ObjPrintf("%p", listRep.spanPtr));
APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanLength);
APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
}
resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
}
#undef APPEND_FIELD
break;
|
| ︙ | ︙ | |||
4066 4067 4068 4069 4070 4071 4072 |
{
Tcl_Free(clientData);
}
/*
*----------------------------------------------------------------------
*
| | | | 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 |
{
Tcl_Free(clientData);
}
/*
*----------------------------------------------------------------------
*
* TestparserCmd --
*
* This procedure implements the "testparser" command. It is
* used for testing the new Tcl script parser in Tcl 8.1.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparserCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
Tcl_Size dummy;
|
| ︙ | ︙ | |||
4123 4124 4125 4126 4127 4128 4129 |
Tcl_FreeParse(&parse);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | 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 |
Tcl_FreeParse(&parse);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprparserCmd --
*
* This procedure implements the "testexprparser" command. It is
* used for testing the new Tcl expression parser in Tcl 8.1.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprparserCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
Tcl_Size dummy;
|
| ︙ | ︙ | |||
4272 4273 4274 4275 4276 4277 4278 | Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, TCL_INDEX_NONE) : Tcl_NewObj()); } /* *---------------------------------------------------------------------- * | | | | 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 |
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
TCL_INDEX_NONE) : Tcl_NewObj());
}
/*
*----------------------------------------------------------------------
*
* TestparsevarCmd --
*
* This procedure implements the "testparsevar" command. It is
* used for testing Tcl_ParseVar.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *value, *name, *termPtr;
|
| ︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 |
Tcl_AppendElement(interp, termPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | 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 |
Tcl_AppendElement(interp, termPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestparsevarnameCmd --
*
* This procedure implements the "testparsevarname" command. It is
* used for testing the new Tcl script parser in Tcl 8.1.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarnameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int length, append;
|
| ︙ | ︙ | |||
4376 4377 4378 4379 4380 4381 4382 |
Tcl_FreeParse(&parse);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 |
Tcl_FreeParse(&parse);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestpreferstableCmd --
*
* This procedure implements the "testpreferstable" command. It is
* used for being able to test the "package" command even when the
* environment variable TCL_PKG_PREFER_LATEST is set in your environment.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpreferstableCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
iPtr->packagePrefer = PKG_PREFER_STABLE;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestprintCmd --
*
* This procedure implements the "testprint" command. It is
* used for being able to test the Tcl_ObjPrintf() function.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestprintCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_WideInt argv1 = 0;
size_t argv2;
|
| ︙ | ︙ | |||
4447 4448 4449 4450 4451 4452 4453 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv3, argv3));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv3, argv3));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestregexpCmd --
*
* This procedure implements the "testregexp" command. It is used to give
* a direct interface for regexp flags. It's identical to
* Tcl_RegexpObjCmd except for the -xflags option, and the consequences
* thereof (including the REG_EXPECT kludge).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestregexpCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int indices, match, about;
Tcl_Size stringLength, i, ii;
int hasxflags, cflags, eflags;
Tcl_RegExp regExpr;
const char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
static const char *const options[] = {
"-indices", "-nocase", "-about", "-expanded",
|
| ︙ | ︙ | |||
4539 4540 4541 4542 4543 4544 4545 |
case REGEXP_LAST:
i++;
goto endOfForLoop;
}
}
endOfForLoop:
| | | 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 |
case REGEXP_LAST:
i++;
goto endOfForLoop;
}
}
endOfForLoop:
if (objc + about < hasxflags + 2 + i) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-switch ...? exp string ?matchVar? ?subMatchVar ...?");
return TCL_ERROR;
}
objc -= i;
objv += i;
|
| ︙ | ︙ | |||
4592 4593 4594 4595 4596 4597 4598 |
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end);
snprintf(resinfo, sizeof(resinfo), "%" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d", start, end-1);
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
| | | | | 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 |
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end);
snprintf(resinfo, sizeof(resinfo), "%" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d", start, end-1);
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", (char *)NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
const char *varName;
const char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
snprintf(resinfo, sizeof(resinfo), "%" TCL_Z_MODIFIER "d", info.extendStart);
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", (char *)NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
objc -= 2;
objv += 2;
Tcl_RegExpGetInfo(regExpr, &info);
for (i = 0; i < objc; i++) {
Tcl_Size start, end;
Tcl_Obj *newPtr, *varPtr, *valuePtr;
varPtr = objv[i];
ii = ((cflags®_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : i;
if (indices) {
Tcl_Obj *objs[2];
if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
} else if (ii > info.nsubs) {
start = TCL_INDEX_NONE;
|
| ︙ | ︙ | |||
4770 4771 4772 4773 4774 4775 4776 |
*cflagsPtr = cflags;
*eflagsPtr = eflags;
}
/*
*----------------------------------------------------------------------
*
| | | | 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 |
*cflagsPtr = cflags;
*eflagsPtr = eflags;
}
/*
*----------------------------------------------------------------------
*
* TestreturnCmd --
*
* This procedure implements the "testreturn" command. It is
* used to verify that a
* return TCL_RETURN;
* has same behavior as
* return Tcl_SetReturnOptions(interp, Tcl_NewObj());
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestreturnCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_RETURN;
}
|
| ︙ | ︙ | |||
4819 4820 4821 4822 4823 4824 4825 |
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | | | 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 |
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
char *buf, *oldData;
Tcl_InterpDeleteProc *procPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "data_key data_item");
return TCL_ERROR;
}
buf = (char *)Tcl_Alloc(strlen(Tcl_GetString(objv[2])) + 1);
strcpy(buf, Tcl_GetString(objv[2]));
/*
* If we previously associated a malloced value with the variable,
* free it before associating a new value.
*/
oldData = (char *)Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), &procPtr);
if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
Tcl_Free(oldData);
}
Tcl_SetAssocData(interp, Tcl_GetString(objv[1]), CleanupTestSetassocdataTests, buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetplatformCmd --
|
| ︙ | ︙ | |||
4870 4871 4872 4873 4874 4875 4876 |
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | | | | > > > > > > > > > > > > > > > > > > > > > | | | | < | | | | | 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 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 |
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
Tcl_Size length;
TclPlatformType *platform;
platform = TclGetPlatform();
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "platform");
return TCL_ERROR;
}
const char *argv1 = Tcl_GetStringFromObj(objv[1], &length);
if (strncmp(argv1, "unix", length) == 0) {
*platform = TCL_PLATFORM_UNIX;
} else if (strncmp(argv1, "windows", length) == 0) {
*platform = TCL_PLATFORM_WINDOWS;
} else {
Tcl_AppendResult(interp, "unsupported platform: should be one of "
"unix, or windows", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
TestSizeCmd(
TCL_UNUSED(void *), /* Unused */
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
if (objc != 2) {
goto syntax;
}
if (strcmp(Tcl_GetString(objv[1]), "st_mtime") == 0) {
Tcl_StatBuf *statPtr;
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime)));
return TCL_OK;
}
syntax:
Tcl_WrongNumArgs(interp, 1, objv, "st_mtime");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TeststaticlibraryCmd --
*
* This procedure implements the "teststaticlibrary" command.
* It is used to test the procedure Tcl_StaticLibrary.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When the package given by objv[1] is loaded into an interpreter,
* variable "x" in that interpreter is set to "loaded".
*
*----------------------------------------------------------------------
*/
static int
TeststaticlibraryCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int safe, loaded;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "prefix safe loaded");
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &safe) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
Tcl_StaticLibrary((loaded) ? interp : NULL, Tcl_GetString(objv[1]),
StaticInitProc, (safe) ? StaticInitProc : NULL);
return TCL_OK;
}
static int
StaticInitProc(
Tcl_Interp *interp) /* Interpreter in which package is supposedly
|
| ︙ | ︙ | |||
4970 4971 4972 4973 4974 4975 4976 |
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 |
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
Tcl_DString buffer;
const char *result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "path");
return TCL_ERROR;
}
result = Tcl_TranslateFileName(interp, Tcl_GetString(objv[1]), &buffer);
if (result == NULL) {
return TCL_ERROR;
}
Tcl_AppendResult(interp, result, (char *)NULL);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestfstildeexpandCmd --
*
* This procedure implements the "testfstildeexpand" command.
* It is used to test the Tcl_FSTildeExpand command. It differs
* from the script level "file tildeexpand" tests because of a
* slightly different code path.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfstildeexpandCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_DString buffer;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "PATH");
return TCL_ERROR;
}
if (Tcl_FSTildeExpand(interp, Tcl_GetString(objv[1]), &buffer) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_DStringToObj(&buffer));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestupvarCmd --
*
* This procedure implements the "testupvar" command. It is used
|
| ︙ | ︙ | |||
5011 5012 5013 5014 5015 5016 5017 |
*----------------------------------------------------------------------
*/
static int
TestupvarCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | | | | | | | 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 5042 |
*----------------------------------------------------------------------
*/
static int
TestupvarCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int flags = 0;
if ((objc != 5) && (objc != 6)) {
Tcl_WrongNumArgs(interp, 1, objv, "level name ?name2? dest global");
return TCL_ERROR;
}
if (objc == 5) {
if (strcmp(Tcl_GetString(objv[4]), "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(Tcl_GetString(objv[4]), "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
return Tcl_UpVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), NULL, Tcl_GetString(objv[3]), flags);
} else {
if (strcmp(Tcl_GetString(objv[5]), "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(Tcl_GetString(objv[5]), "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
return Tcl_UpVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]),
(Tcl_GetString(objv[3])[0] == 0) ? NULL : Tcl_GetString(objv[3]), Tcl_GetString(objv[4]),
flags);
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5063 5064 5065 5066 5067 5068 5069 |
*----------------------------------------------------------------------
*/
static int
TestseterrorcodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | | | | | | | | | | | 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 |
*----------------------------------------------------------------------
*/
static int
TestseterrorcodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
if (objc > 6) {
Tcl_AppendResult(interp, "too many args", (char *)NULL);
return TCL_ERROR;
}
switch (objc) {
case 1:
Tcl_SetErrorCode(interp, "NONE", (char *)NULL);
break;
case 2:
Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), (char *)NULL);
break;
case 3:
Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), (char *)NULL);
break;
case 4:
Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), (char *)NULL);
break;
case 5:
Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), Tcl_GetString(objv[4]), (char *)NULL);
break;
case 6:
Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), Tcl_GetString(objv[4]),
Tcl_GetString(objv[5]), (char *)NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5143 5144 5145 5146 5147 5148 5149 |
*----------------------------------------------------------------------
*/
static int
TestfeventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | < | | | | | | | | 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 |
*----------------------------------------------------------------------
*/
static int
TestfeventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_Channel chan;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[1]), "cmd") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
if (interp2 != NULL) {
code = Tcl_EvalEx(interp2, Tcl_GetString(objv[2]), TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
Tcl_AppendResult(interp,
"called \"testfevent code\" before \"testfevent create\"",
(char *)NULL);
return TCL_ERROR;
}
} else if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = Tcl_CreateInterp();
return Tcl_Init(interp2);
} else if (strcmp(Tcl_GetString(objv[1]), "delete") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = NULL;
} else if (strcmp(Tcl_GetString(objv[1]), "share") == 0) {
if (interp2 != NULL) {
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp2, chan);
}
}
|
| ︙ | ︙ | |||
5215 5216 5217 5218 5219 5220 5221 |
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
| | | | | | | | | > | | | | | | | | | | | | | | | 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 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 5289 5290 5291 5292 5293 |
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
Tcl_Obj *list = Tcl_NewListObj(objc-1, objv+1);
Tcl_Panic("%s", Tcl_GetString(list));
Tcl_DecrRefCount(list);
return TCL_OK;
}
static int
TestfileCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The argument objects. */
{
int force, i, result;
Tcl_Obj *error = NULL;
const char *subcmd;
int j;
if (objc < 3) {
return TCL_ERROR;
}
force = 0;
i = 2;
if (strcmp(Tcl_GetString(objv[2]), "-force") == 0) {
force = 1;
i = 3;
}
if (objc - i > 2) {
return TCL_ERROR;
}
for (j = i; j < objc; j++) {
if (Tcl_FSGetNormalizedPath(interp, objv[j]) == NULL) {
return TCL_ERROR;
}
}
subcmd = Tcl_GetString(objv[1]);
if (strcmp(subcmd, "mv") == 0) {
result = TclpObjRenameFile(objv[i], objv[i + 1]);
} else if (strcmp(subcmd, "cp") == 0) {
result = TclpObjCopyFile(objv[i], objv[i + 1]);
} else if (strcmp(subcmd, "rm") == 0) {
result = TclpObjDeleteFile(objv[i]);
} else if (strcmp(subcmd, "mkdir") == 0) {
result = TclpObjCreateDirectory(objv[i]);
} else if (strcmp(subcmd, "cpdir") == 0) {
result = TclpObjCopyDirectory(objv[i], objv[i + 1], &error);
} else if (strcmp(subcmd, "rmdir") == 0) {
result = TclpObjRemoveDirectory(objv[i], force, &error);
} else {
result = TCL_ERROR;
goto end;
}
if (result != TCL_OK) {
if (error != NULL) {
if (Tcl_GetString(error)[0] != '\0') {
Tcl_AppendResult(interp, Tcl_GetString(error), " ", (char *)NULL);
}
Tcl_DecrRefCount(error);
}
Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *)NULL);
}
end:
return result;
}
/*
|
| ︙ | ︙ | |||
5371 5372 5373 5374 5375 5376 5377 |
Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | 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 5387 5388 5389 5390 5391 5392 |
Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetTimesCmd --
*
* This procedure implements the "gettimes" command. It is used for
* computing the time needed for various basic operations such as reading
* variables, allocating memory, snprintf, converting variables, etc.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Allocates and frees memory, sets a variable "a" in the interpreter.
*
*----------------------------------------------------------------------
*/
static int
GetTimesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The current interpreter. */
TCL_UNUSED(int) /*cobjc*/,
TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/)
{
Interp *iPtr = (Interp *) interp;
int i, n;
|
| ︙ | ︙ | |||
5605 5606 5607 5608 5609 5610 5611 |
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 |
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TeststringbytesCmd --
* Returns bytearray value of the bytes in argument string rep
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TeststringbytesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size n;
const unsigned char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestpurebytesobjCmd --
*
* This object-based procedure constructs a pure bytes object
* without type and with internal representation containing NULL's.
*
* If no argument supplied it returns empty object with tclEmptyStringRep,
* otherwise it returns this as pure bytes object with bytes value equal
* string.
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpurebytesobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
5690 5691 5692 5693 5694 5695 5696 |
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 |
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetbytearraylengthCmd --
*
* Testing command 'testsetbytearraylength` used to test the public
* interface routine Tcl_SetByteArrayLength().
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetbytearraylengthCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
Tcl_Obj *obj = NULL;
|
| ︙ | ︙ | |||
5729 5730 5731 5732 5733 5734 5735 |
if (Tcl_IsShared(obj)) {
obj = Tcl_DuplicateObj(obj);
}
if (Tcl_SetByteArrayLength(obj, n) == NULL) {
if (obj != objv[1]) {
Tcl_DecrRefCount(obj);
}
| | | | | 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 |
if (Tcl_IsShared(obj)) {
obj = Tcl_DuplicateObj(obj);
}
if (Tcl_SetByteArrayLength(obj, n) == NULL) {
if (obj != objv[1]) {
Tcl_DecrRefCount(obj);
}
Tcl_AppendResult(interp, "expected bytes", (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestbytestringCmd --
*
* This object-based procedure constructs a string which can
* possibly contain invalid UTF-8 bytes.
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestbytestringCmd(
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)
|
| ︙ | ︙ | |||
5781 5782 5783 5784 5785 5786 5787 |
p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &x.n);
if (p == NULL) {
return TCL_ERROR;
}
if (x.m != 1) {
| | | 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 |
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", (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, x.n));
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
5809 5810 5811 5812 5813 5814 5815 |
*----------------------------------------------------------------------
*/
static int
TestsetCmd(
void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
| | | | | | | | | < | | | | | | | | | < | | 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 |
*----------------------------------------------------------------------
*/
static int
TestsetCmd(
void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int flags = PTR2INT(data);
const char *value;
if (objc == 2) {
Tcl_AppendResult(interp, "before get", (char *)NULL);
value = Tcl_GetVar2(interp, Tcl_GetString(objv[1]), NULL, flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (objc == 3) {
Tcl_AppendResult(interp, "before set", (char *)NULL);
value = Tcl_SetVar2(interp, Tcl_GetString(objv[1]), NULL, Tcl_GetString(objv[2]), flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
return TCL_ERROR;
}
}
static int
Testset2Cmd(
void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int flags = PTR2INT(data);
const char *value;
if (objc == 3) {
Tcl_AppendResult(interp, "before get", (char *)NULL);
value = Tcl_GetVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (objc == 4) {
Tcl_AppendResult(interp, "before set", (char *)NULL);
value = Tcl_SetVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "varName elemName ?newValue??");
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5891 5892 5893 5894 5895 5896 5897 |
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
| | | | | | 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 |
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv)
{
if (objc == 1) {
Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5952 5953 5954 5955 5956 5957 5958 |
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
| | | | 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 |
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
5981 5982 5983 5984 5985 5986 5987 |
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
| | | | 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 |
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
exitMainLoop = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
6009 6010 6011 6012 6013 6014 6015 |
*----------------------------------------------------------------------
*/
static int
TestChannelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
| | | | | < | | < | | | | | | | 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 |
*----------------------------------------------------------------------
*/
static int
TestChannelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int objc, /* Count of additional args. */
Tcl_Obj *const *objv) /* Additional args. */
{
const char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* state info for channel */
Tcl_Channel chan; /* The opaque type. */
Tcl_Size len; /* Length of subcommand string. */
int IOQueued; /* How much IO is queued inside channel? */
char buf[TCL_INTEGER_SPACE];/* For snprintf. */
int mode; /* rw mode of the channel */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?additional args..?");
return TCL_ERROR;
}
cmdName = Tcl_GetStringFromObj(objv[1], &len);
chanPtr = NULL;
if (objc > 2) {
if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
/* For splice access the pool of detached channels.
* Locate channel, remove from the list.
*/
TestChannel **nextPtrPtr, *curPtr;
chan = (Tcl_Channel) NULL;
for (nextPtrPtr = &firstDetached, curPtr = firstDetached;
curPtr != NULL;
nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {
if (strcmp(Tcl_GetString(objv[2]), Tcl_GetChannelName(curPtr->chan)) == 0) {
*nextPtrPtr = curPtr->nextPtr;
curPtr->nextPtr = NULL;
chan = curPtr->chan;
Tcl_Free(curPtr);
break;
}
}
} else {
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), &mode);
}
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *)chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
} else {
statePtr = NULL;
chan = NULL;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
Tcl_Obj *msg = objv[3];
Tcl_IncrRefCount(msg);
Tcl_SetChannelError(chan, msg);
Tcl_DecrRefCount(msg);
Tcl_GetChannelError(chan, &msg);
Tcl_SetObjResult(interp, msg);
Tcl_DecrRefCount(msg);
return TCL_OK;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {
Tcl_Obj *msg = objv[3];
Tcl_IncrRefCount(msg);
Tcl_SetChannelErrorInterp(interp, msg);
Tcl_DecrRefCount(msg);
Tcl_GetChannelErrorInterp(interp, &msg);
Tcl_SetObjResult(interp, msg);
|
| ︙ | ︙ | |||
6107 6108 6109 6110 6111 6112 6113 |
* checking that the command is truly cut'able, no mutexes for
* thread-safety). Its complementary command is "splice", see below.
*/
if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
TestChannel *det;
| | < | | | < | | < | | 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 |
* checking that the command is truly cut'able, no mutexes for
* thread-safety). Its complementary command is "splice", see below.
*/
if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
TestChannel *det;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "channel");
return TCL_ERROR;
}
Tcl_RegisterChannel(NULL, chan); /* prevent closing */
Tcl_UnregisterChannel(interp, chan);
Tcl_CutChannel(chan);
/* Remember the channel in the pool of detached channels */
det = (TestChannel *)Tcl_Alloc(sizeof(TestChannel));
det->chan = chan;
det->nextPtr = firstDetached;
firstDetached = det;
return TCL_OK;
}
if ((cmdName[0] == 'c') &&
(strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "channel");
return TCL_ERROR;
}
Tcl_ClearChannelHandlers(chan);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "channel");
return TCL_ERROR;
}
Tcl_AppendElement(interp, Tcl_GetString(objv[2]));
Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & TCL_WRITABLE) {
|
| ︙ | ︙ | |||
6233 6234 6235 6236 6237 6238 6239 |
Tcl_AppendElement(interp, buf);
return TCL_OK;
}
if ((cmdName[0] == 'i') &&
(strncmp(cmdName, "inputbuffered", len) == 0)) {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | < | | | 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 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 |
Tcl_AppendElement(interp, buf);
return TCL_OK;
}
if ((cmdName[0] == 'i') &&
(strncmp(cmdName, "inputbuffered", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
IOQueued = Tcl_InputBuffered(chan);
TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsChannelShared(chan));
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsStandardChannel(chan));
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, "write");
} else {
Tcl_AppendElement(interp, "");
}
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
if (statePtr->maxPerms & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->maxPerms & TCL_WRITABLE) {
Tcl_AppendElement(interp, "write");
} else {
Tcl_AppendElement(interp, "");
}
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE);
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE);
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
(Tcl_WideInt)(size_t)Tcl_GetChannelThread(chan)));
return TCL_OK;
}
if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, statePtr->channelName, (char *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr));
}
return TCL_OK;
}
if ((cmdName[0] == 'o') &&
(strncmp(cmdName, "outputbuffered", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
IOQueued = Tcl_OutputBuffered(chan);
TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'q') &&
(strncmp(cmdName, "queuedcr", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp,
(statePtr->flags & INPUT_SAW_CR) ? "1" : "0", (char *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
TclFormatInt(buf, statePtr->refCount);
Tcl_AppendResult(interp, buf, (char *)NULL);
return TCL_OK;
}
/*
* "splice" is actually more a simplified attach facility as provided by
* the Thread package. Without the safeguards of a regular command (no
* checking that the command is truly cut'able, no mutexes for
* thread-safety). Its complementary command is "cut", see above.
*/
if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
Tcl_SpliceChannel(chan);
Tcl_RegisterChannel(interp, chan);
Tcl_UnregisterChannel(NULL, chan);
return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
if (objc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), (char *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
/*
* Syntax: transform channel -command command
*/
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "channel -command cmd");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[3]), "-command") != 0) {
Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[3]),
"\": should be \"-command\"", (char *)NULL);
return TCL_ERROR;
}
return TclChannelTransform(interp, chan, objv[4]);
}
if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
/*
* Syntax: unstack channel
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "channel");
return TCL_ERROR;
}
return Tcl_UnstackChannel(interp, chan);
}
Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
"cut, clearchannelhandlers, info, isshared, mode, open, "
"readable, splice, writable, transform, unstack", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestChannelEventCmd --
|
| ︙ | ︙ | |||
6513 6514 6515 6516 6517 6518 6519 |
*----------------------------------------------------------------------
*/
static int
TestChannelEventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | > | < | | | < | < | | | | | | | | < | | | | | | | 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 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 |
*----------------------------------------------------------------------
*/
static int
TestChannelEventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
const char *cmd;
int index, i, mask;
Tcl_Size len;
if ((objc < 3) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 1, objv, "channel cmd ?arg1? ?arg2?");
return TCL_ERROR;
}
chanPtr = (Channel *)Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chanPtr == NULL) {
return TCL_ERROR;
}
statePtr = chanPtr->state;
cmd = Tcl_GetStringFromObj(objv[2], &len);
if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv, "channel add eventSpec script");
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(Tcl_GetString(objv[3]), "writable") == 0) {
mask = TCL_WRITABLE;
} else if (strcmp(Tcl_GetString(objv[3]), "none") == 0) {
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", Tcl_GetString(objv[3]),
"\": must be readable, writable, or none", (char *)NULL);
return TCL_ERROR;
}
esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
esPtr->scriptPtr = objv[4];
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "channel delete index");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", Tcl_GetString(objv[3]),
": must be nonnegative", (char *)NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
(i < index) && (esPtr != NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
}
if (esPtr == NULL) {
Tcl_AppendResult(interp, "bad event index ", Tcl_GetString(objv[3]),
": out of range", (char *)NULL);
return TCL_ERROR;
}
if (esPtr == statePtr->scriptRecordPtr) {
statePtr->scriptRecordPtr = esPtr->nextPtr;
} else {
for (prevEsPtr = statePtr->scriptRecordPtr;
(prevEsPtr != NULL) &&
|
| ︙ | ︙ | |||
6617 6618 6619 6620 6621 6622 6623 |
Tcl_DecrRefCount(esPtr->scriptPtr);
Tcl_Free(esPtr);
return TCL_OK;
}
if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) {
| | | < | | < | < | | | | | | | | | | | | | 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 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 |
Tcl_DecrRefCount(esPtr->scriptPtr);
Tcl_Free(esPtr);
return TCL_OK;
}
if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "channel list");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
for (esPtr = statePtr->scriptRecordPtr;
esPtr != NULL;
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
} else {
Tcl_ListObjAppendElement(interp, resultListPtr,
Tcl_NewStringObj("none", -1));
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
return TCL_OK;
}
if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "channel removeall");
return TCL_ERROR;
}
for (esPtr = statePtr->scriptRecordPtr;
esPtr != NULL;
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
Tcl_Free(esPtr);
}
statePtr->scriptRecordPtr = NULL;
return TCL_OK;
}
if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv, "channel delete index event");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", Tcl_GetString(objv[3]),
": must be nonnegative", (char *)NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
(i < index) && (esPtr != NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
}
if (esPtr == NULL) {
Tcl_AppendResult(interp, "bad event index ", Tcl_GetString(objv[3]),
": out of range", (char *)NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[4]), "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(Tcl_GetString(objv[4]), "writable") == 0) {
mask = TCL_WRITABLE;
} else if (strcmp(Tcl_GetString(objv[4]), "none") == 0) {
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", Tcl_GetString(objv[4]),
"\": must be readable, writable, or none", (char *)NULL);
return TCL_ERROR;
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
"add, delete, list, set, or removeall", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestSocketCmd --
|
| ︙ | ︙ | |||
6729 6730 6731 6732 6733 6734 6735 |
* automatically continue connection
* process. */
static int
TestSocketCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
| | | | | < | | < | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | 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 6758 6759 6760 6761 6762 6763 6764 6765 6766 |
* automatically continue connection
* process. */
static int
TestSocketCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int objc, /* Count of additional args. */
Tcl_Obj *const *objv) /* Additional args. */
{
const char *cmdName; /* Sub command. */
Tcl_Size len; /* Length of subcommand string. */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?additional args..?");
return TCL_ERROR;
}
cmdName = Tcl_GetStringFromObj(objv[1], &len);
if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) {
Tcl_Channel hChannel;
int modePtr;
int testMode;
TcpState *statePtr;
/* Set test value in the socket driver
*/
/* Check for argument "channel name"
*/
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "channel flags");
return TCL_ERROR;
}
hChannel = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), &modePtr);
if ( NULL == hChannel ) {
Tcl_AppendResult(interp, "unknown channel:", Tcl_GetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
if ( NULL == statePtr) {
Tcl_AppendResult(interp, "No channel instance data:", Tcl_GetString(objv[2]),
(char *)NULL);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &testMode) != TCL_OK) {
return TCL_ERROR;
}
if (testMode) {
statePtr->flags |= TCP_ASYNC_TEST_MODE;
} else {
statePtr->flags &= ~TCP_ASYNC_TEST_MODE;
}
return TCL_OK;
}
Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
"testflags", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestServiceModeCmd --
|
| ︙ | ︙ | |||
6808 6809 6810 6811 6812 6813 6814 |
*----------------------------------------------------------------------
*/
static int
TestServiceModeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < | | | | | | | | | | | | | | 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 |
*----------------------------------------------------------------------
*/
static int
TestServiceModeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int newmode, oldmode;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?newmode?");
return TCL_ERROR;
}
oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE);
if (objc == 2) {
if (Tcl_GetIntFromObj(interp, objv[1], &newmode) == TCL_ERROR) {
return TCL_ERROR;
}
if (newmode == 0) {
Tcl_SetServiceMode(TCL_SERVICE_NONE);
} else {
Tcl_SetServiceMode(TCL_SERVICE_ALL);
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oldmode));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestWrongNumArgsCmd --
*
* Test the Tcl_WrongNumArgs function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Size i, length;
const char *msg;
|
| ︙ | ︙ | |||
6876 6877 6878 6879 6880 6881 6882 |
}
if (i > objc - 3) {
/*
* Asked for more arguments than were given.
*/
insufArgs:
| | | | | 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 |
}
if (i > objc - 3) {
/*
* Asked for more arguments than were given.
*/
insufArgs:
Tcl_AppendResult(interp, "insufficient arguments", (char *)NULL);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, i, &(objv[3]), msg);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestGetIndexFromObjStructCmd --
*
* Test the Tcl_GetIndexFromObjStruct function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestGetIndexFromObjStructCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *const ary[] = {
"a", "b", "c", "d", "ee", "ff", NULL, NULL
|
| ︙ | ︙ | |||
6929 6930 6931 6932 6933 6934 6935 |
}
memset(idx, 85, sizeof(idx));
if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *),
"dummy", flags, &idx[1]) != TCL_OK) {
return TCL_ERROR;
}
if (idx[0] != 85 || idx[2] != 85) {
| | | | | | | 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 |
}
memset(idx, 85, sizeof(idx));
if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *),
"dummy", flags, &idx[1]) != TCL_OK) {
return TCL_ERROR;
}
if (idx[0] != 85 || idx[2] != 85) {
Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", (char *)NULL);
return TCL_ERROR;
} else if (idx[1] != target) {
char buffer[64];
snprintf(buffer, sizeof(buffer), "%d", idx[1]);
Tcl_AppendResult(interp, "index value comparison failed: got ",
buffer, (char *)NULL);
snprintf(buffer, sizeof(buffer), "%d", target);
Tcl_AppendResult(interp, " when ", buffer, " expected", (char *)NULL);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, objc, objv, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestFilesystemCmd --
*
* This procedure implements the "testfilesystem" command. It is used to
* test Tcl_FSRegister, Tcl_FSUnregister, and can be used to test that
* the pluggable filesystem works.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Inserts or removes a filesystem from Tcl's stack.
*
*----------------------------------------------------------------------
*/
static int
TestFilesystemCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
7334 7335 7336 7337 7338 7339 7340 | * * Please do not consider this filesystem a model of how things are to be * done. It is quite the opposite! But, it does allow us to test some * important features. */ static int | | | 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 |
*
* Please do not consider this filesystem a model of how things are to be
* done. It is quite the opposite! But, it does allow us to test some
* important features.
*/
static int
TestSimpleFilesystemCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
7443 7444 7445 7446 7447 7448 7449 |
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
Tcl_Obj *tempPtr;
Tcl_Channel chan;
| | | | 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 |
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
Tcl_Obj *tempPtr;
Tcl_Channel chan;
if ((mode & O_ACCMODE) != O_RDONLY) {
Tcl_AppendResult(interp, "read-only", (char *)NULL);
return NULL;
}
tempPtr = SimpleRedirect(pathPtr);
chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);
Tcl_DecrRefCount(tempPtr);
return chan;
|
| ︙ | ︙ | |||
7530 7531 7532 7533 7534 7535 7536 |
buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0';
first = result = Tcl_UtfNext(buffer + 1);
while ((buffer[0] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
if (first != result) {
| | | 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 |
buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0';
first = result = Tcl_UtfNext(buffer + 1);
while ((buffer[0] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
if (first != result) {
Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", (char *)NULL);
return TCL_ERROR;
}
}
p = tobetested;
while ((buffer[numBytes + 1] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[end], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
|
| ︙ | ︙ | |||
7802 7803 7804 7805 7806 7807 7808 |
if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) {
return TCL_ERROR;
}
Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType);
if (hash.numEntries != 0) {
| | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 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 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 |
if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) {
return TCL_ERROR;
}
Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType);
if (hash.numEntries != 0) {
Tcl_AppendResult(interp, "non-zero initial size", (char *)NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", -1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
if (hash.numEntries != (Tcl_Size)limit) {
Tcl_AppendResult(interp, "unexpected maximal size", (char *)NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_FindHashEntry(&hash, (char *)INT2PTR(i));
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", -1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", -1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_DeleteHashEntry(hPtr);
}
if (hash.numEntries != 0) {
Tcl_AppendResult(interp, "non-zero final size", (char *)NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_DeleteHashTable(&hash);
Tcl_AppendResult(interp, "OK", (char *)NULL);
return TCL_OK;
}
/*
* Used for testing Tcl_GetInt which is no longer used directly by the
* core very much.
*/
static int
TestgetintCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?args?");
return TCL_ERROR;
} else {
int val, total=0;
int i;
for (i=1 ; i<objc ; i++) {
if (Tcl_GetInt(interp, Tcl_GetString(objv[i]), &val) != TCL_OK) {
return TCL_ERROR;
}
total += val;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(total));
return TCL_OK;
}
}
/*
* Used for determining sizeof(long) at script level.
*/
static int
TestlongsizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(long)));
return TCL_OK;
}
static int
NREUnwind_callback(
void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
void *cStackPtr = TclGetCStackPtr();
if (data[0] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, cStackPtr, INT2PTR(-1),
INT2PTR(-1), NULL);
} else if (data[1] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], cStackPtr,
INT2PTR(-1), NULL);
} else if (data[2] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1],
cStackPtr, NULL);
} else {
Tcl_Obj *idata[3];
idata[0] = Tcl_NewWideIntObj(((char *)data[1] - (char *)data[0]));
idata[1] = Tcl_NewWideIntObj(((char *)data[2] - (char *)data[0]));
idata[2] = Tcl_NewWideIntObj(((char *)cStackPtr - (char *)data[0]));
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
}
static int
TestNREUnwind(
TCL_UNUSED(void *),
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
/*
* Insure that callbacks effectively run at the proper level during the
* unwinding of the NRE stack.
*/
Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1),
INT2PTR(-1), NULL);
return TCL_OK;
}
static int
TestNRELevels(
TCL_UNUSED(void *),
|
| ︙ | ︙ | |||
8003 8004 8005 8006 8007 8008 8009 |
*----------------------------------------------------------------------
*/
static int
TestconcatobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 |
*----------------------------------------------------------------------
*/
static int
TestconcatobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
int result = TCL_OK;
Tcl_Size len;
Tcl_Obj *objv[3];
/*
|
| ︙ | ︙ | |||
8042 8043 8044 8045 8046 8047 8048 |
objv[0] = tmpPtr;
objv[1] = emptyPtr;
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 |
objv[0] = tmpPtr;
objv[1] = emptyPtr;
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (a) concatObj does not have refCount 0", (char *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (a) concatObj is not a new obj ",
(char *)NULL);
switch (tmpPtr->refCount) {
case 0:
Tcl_AppendResult(interp, "(no new refCount)", (char *)NULL);
break;
case 1:
Tcl_AppendResult(interp, "(refCount added)", (char *)NULL);
break;
default:
Tcl_AppendResult(interp, "(more than one refCount added!)", (char *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
objv[0] = tmpPtr;
}
Tcl_DecrRefCount(concatPtr);
Tcl_IncrRefCount(tmpPtr);
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (b) concatObj does not have refCount 0", (char *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (b) concatObj is not a new obj ",
(char *)NULL);
switch (tmpPtr->refCount) {
case 0:
Tcl_AppendResult(interp, "(refCount removed?)", (char *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
break;
case 1:
Tcl_AppendResult(interp, "(no new refCount)", (char *)NULL);
break;
case 2:
Tcl_AppendResult(interp, "(refCount added)", (char *)NULL);
Tcl_DecrRefCount(tmpPtr);
break;
default:
Tcl_AppendResult(interp, "(more than one refCount added!)", (char *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
objv[0] = tmpPtr;
}
Tcl_DecrRefCount(concatPtr);
objv[0] = emptyPtr;
objv[1] = tmpPtr;
objv[2] = emptyPtr;
concatPtr = Tcl_ConcatObj(3, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (c) concatObj does not have refCount 0", (char *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (c) concatObj is not a new obj ",
(char *)NULL);
switch (tmpPtr->refCount) {
case 0:
Tcl_AppendResult(interp, "(no new refCount)", (char *)NULL);
break;
case 1:
Tcl_AppendResult(interp, "(refCount added)", (char *)NULL);
break;
default:
Tcl_AppendResult(interp, "(more than one refCount added!)", (char *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
objv[1] = tmpPtr;
}
Tcl_DecrRefCount(concatPtr);
Tcl_IncrRefCount(tmpPtr);
concatPtr = Tcl_ConcatObj(3, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (d) concatObj does not have refCount 0", (char *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (d) concatObj is not a new obj ",
(char *)NULL);
switch (tmpPtr->refCount) {
case 0:
Tcl_AppendResult(interp, "(refCount removed?)", (char *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
break;
case 1:
Tcl_AppendResult(interp, "(no new refCount)", (char *)NULL);
break;
case 2:
Tcl_AppendResult(interp, "(refCount added)", (char *)NULL);
Tcl_DecrRefCount(tmpPtr);
break;
default:
Tcl_AppendResult(interp, "(more than one refCount added!)", (char *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
objv[1] = tmpPtr;
}
Tcl_DecrRefCount(concatPtr);
/*
* Verify that an unshared list is not corrupted when concat'ing things to
* it.
*/
objv[0] = tmpPtr;
objv[1] = list2Ptr;
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (e) concatObj does not have refCount 0", (char *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ",
(char *)NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
Tcl_AppendResult(interp, "(failed to concat)", (char *)NULL);
break;
default:
Tcl_AppendResult(interp, "(corrupted input!)", (char *)NULL);
}
if (Tcl_IsShared(tmpPtr)) {
Tcl_DecrRefCount(tmpPtr);
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
objv[0] = tmpPtr;
}
Tcl_DecrRefCount(concatPtr);
objv[0] = tmpPtr;
objv[1] = list2Ptr;
Tcl_IncrRefCount(tmpPtr);
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (f) concatObj does not have refCount 0", (char *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ",
(char *)NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
Tcl_AppendResult(interp, "(failed to concat)", (char *)NULL);
break;
default:
Tcl_AppendResult(interp, "(corrupted input!)", (char *)NULL);
}
if (Tcl_IsShared(tmpPtr)) {
Tcl_DecrRefCount(tmpPtr);
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
objv[0] = tmpPtr;
}
Tcl_DecrRefCount(concatPtr);
objv[0] = tmpPtr;
objv[1] = list2Ptr;
Tcl_IncrRefCount(tmpPtr);
Tcl_IncrRefCount(tmpPtr);
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (g) concatObj does not have refCount 0", (char *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ",
(char *)NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
Tcl_AppendResult(interp, "(failed to concat)", (char *)NULL);
break;
default:
Tcl_AppendResult(interp, "(corrupted input!)", (char *)NULL);
}
Tcl_DecrRefCount(tmpPtr);
if (Tcl_IsShared(tmpPtr)) {
Tcl_DecrRefCount(tmpPtr);
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
objv[0] = tmpPtr;
|
| ︙ | ︙ | |||
8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 |
*----------------------------------------------------------------------
*
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
* test that Tcl_ParseArgsObjv does indeed return the right number of
* arguments. In other words, that [Bug 3413857] was fixed properly.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparseargsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
{
static int foo = 0;
Tcl_Size count = objc;
| > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 |
*----------------------------------------------------------------------
*
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
* test that Tcl_ParseArgsObjv does indeed return the right number of
* arguments. In other words, that [Bug 3413857] was fixed properly.
* Also test for bug [7cb7409e05]
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Size
ParseMedia(
TCL_UNUSED(void *),
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Size),
Tcl_Obj *const *objv,
void *dstPtr)
{
static const char *const mediaOpts[] = {"A4", "Legal", "Letter", NULL};
static const char *const ExtendedMediaOpts[] = {
"Paper size is ISO A4", "Paper size is US Legal",
"Paper size is US Letter", NULL};
int index;
const char **media = (const char **) dstPtr;
if (Tcl_GetIndexFromObjStruct(interp, objv[0], mediaOpts,
sizeof(char *), "media", 0, &index) != TCL_OK) {
return -1;
}
*media = ExtendedMediaOpts[index];
return 1;
}
static int
TestparseargsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
{
static int foo = 0;
const char *media = NULL, *color = NULL;
Tcl_Size count = objc;
Tcl_Obj **remObjv, *result[5];
const Tcl_ArgvInfo argTable[] = {
{TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
{TCL_ARGV_STRING, "-colormode" , NULL, &color, "color mode", NULL},
{TCL_ARGV_GENFUNC, "-media", (void *)ParseMedia, &media, "media page size", NULL},
TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
};
foo = 0;
if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
return TCL_ERROR;
}
result[0] = Tcl_NewWideIntObj(foo);
result[1] = Tcl_NewWideIntObj(count);
result[2] = Tcl_NewListObj(count, remObjv);
result[3] = Tcl_NewStringObj(color ? color : "NULL", -1);
result[4] = Tcl_NewStringObj(media ? media : "NULL", -1);
Tcl_SetObjResult(interp, Tcl_NewListObj(5, result));
Tcl_Free(remObjv);
return TCL_OK;
}
/**
* Test harness for command and variable resolvers.
*/
static int
InterpCmdResolver(
Tcl_Interp *interp,
const char *name,
TCL_UNUSED(Tcl_Namespace *),
TCL_UNUSED(int) /* flags */,
Tcl_Command *rPtr)
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
varFramePtr->procPtr : NULL;
Namespace *callerNsPtr = varFramePtr->nsPtr;
Tcl_Command resolvedCmdPtr = NULL;
/*
* Just do something special on a cmd literal "z" in two cases:
* A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2".
* B) the caller's namespace is "ctx1" or "ctx2"
*/
if ( (name[0] == 'z') && (name[1] == '\0') ) {
Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0);
if (procPtr != NULL
&& ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr)
|| (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr)
)
) {
/*
* Case A)
*
* - The context, in which this resolver becomes active, is
* determined by the name of the caller proc, which has to be
* named "x".
*
* - To determine the name of the caller proc, the proc is taken
* from the topmost stack frame.
*
* - Note that the context is NOT provided during byte-code
* compilation (e.g. in TclProcCompileProc)
*
* When these conditions hold, this function resolves the
* passed-in cmd literal into a cmd "y", which is taken from
* the global namespace (for simplicity).
*/
const char *callingCmdName =
Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
}
} else if (callerNsPtr != NULL) {
/*
* Case B)
*
* - The context, in which this resolver becomes active, is
* determined by the name of the parent namespace, which has
* to be named "ctx1" or "ctx2".
*
* - To determine the name of the parent namesace, it is taken
* from the 2nd highest stack frame.
*
* - Note that the context can be provided during byte-code
* compilation (e.g. in TclProcCompileProc)
*
* When these conditions hold, this function resolves the
* passed-in cmd literal into a cmd "y" or "Y" depending on the
* context. The resolved procs are taken from the global
* namespace (for simplicity).
*/
CallFrame *parentFramePtr = varFramePtr->callerPtr;
const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
/* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/
} else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY);
/*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/
}
}
if (resolvedCmdPtr != NULL) {
*rPtr = resolvedCmdPtr;
return TCL_OK;
}
}
return TCL_CONTINUE;
}
static int
InterpVarResolver(
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(const char *),
TCL_UNUSED(Tcl_Namespace *),
TCL_UNUSED(int), /* flags */
TCL_UNUSED(Tcl_Var *))
{
/*
* Don't resolve the variable; use standard rules.
*/
return TCL_CONTINUE;
}
typedef struct MyResolvedVarInfo {
Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */
Tcl_Var var;
Tcl_Obj *nameObj;
} MyResolvedVarInfo;
static inline void
HashVarFree(
Tcl_Var var)
{
if (VarHashRefCount(var) < 2) {
Tcl_Free(var);
} else {
VarHashRefCount(var)--;
}
}
static void
MyCompiledVarFree(
Tcl_ResolvedVarInfo *vInfoPtr)
{
MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr;
Tcl_DecrRefCount(resVarInfo->nameObj);
if (resVarInfo->var) {
HashVarFree(resVarInfo->var);
}
Tcl_Free(vInfoPtr);
}
#define TclVarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static Tcl_Var
MyCompiledVarFetch(
Tcl_Interp *interp,
Tcl_ResolvedVarInfo *vinfoPtr)
{
MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;
Tcl_Var var = resVarInfo->var;
int isNewVar;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
if (var != NULL) {
if (!(((Var *) var)->flags & VAR_DEAD_HASH)) {
/*
* The cached variable is valid, return it.
*/
return var;
}
/*
* The variable is not valid anymore. Clean it up.
*/
HashVarFree(var);
}
hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable,
resVarInfo->nameObj, &isNewVar);
if (hPtr) {
var = (Tcl_Var) TclVarHashGetValue(hPtr);
} else {
var = NULL;
}
resVarInfo->var = var;
/*
* Increment the reference counter to avoid Tcl_Free() of the variable in
* Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
*/
|
| ︙ | ︙ | |||
8517 8518 8519 8520 8521 8522 8523 |
TCL_UNUSED(Tcl_Interp *),
const char *name,
TCL_UNUSED(Tcl_Size) /* length */,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
| | | | | | | | | | | | | | | | | | | | | | | | 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 |
TCL_UNUSED(Tcl_Interp *),
const char *name,
TCL_UNUSED(Tcl_Size) /* length */,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo));
resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
resVarInfo->var = NULL;
resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
Tcl_IncrRefCount(resVarInfo->nameObj);
*rPtr = &resVarInfo->vInfo;
return TCL_OK;
}
return TCL_CONTINUE;
}
static int
TestInterpResolverCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const table[] = {
"down", "up", NULL
};
int idx;
#define RESOLVER_KEY "testInterpResolver"
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
return TCL_ERROR;
}
if (objc == 3) {
interp = Tcl_GetChild(interp, Tcl_GetString(objv[2]));
if (interp == NULL) {
Tcl_AppendResult(interp, "provided interpreter not found", (char *)NULL);
return TCL_ERROR;
}
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
return TCL_ERROR;
}
switch (idx) {
case 1: /* up */
Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver,
InterpVarResolver, InterpCompiledVarResolver);
break;
case 0: /*down*/
if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) {
Tcl_AppendResult(interp, "could not remove the resolver scheme",
(char *)NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* TestApplyLambdaCmd --
*
* Implements the Tcl command testapplylambda. This tests the apply
* implementation handling of a lambda where the lambda has a list
* internal representation where the second element's internal
* representation is already a byte code object.
*
* Results:
* TCL_OK - Success. Caller should check result is 42
* TCL_ERROR - Error.
*
* Side effects:
* In the presence of the apply bug, may panic. Otherwise
* Interpreter result holds result or error message.
*
*------------------------------------------------------------------------
*/
int TestApplyLambdaCmd (
TCL_UNUSED(void*),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int), /* objc. */
TCL_UNUSED(Tcl_Obj *const *)) /* objv. */
{
Tcl_Obj *lambdaObjs[2];
Tcl_Obj *evalObjs[2];
|
| ︙ | ︙ | |||
8642 8643 8644 8645 8646 8647 8648 |
/*
* The bug trigger. Repeating the command but:
* - we are calling apply with a lambda that is a list (as BEFORE),
* BUT
* - The body of the lambda (lambdaObjs[1]) ALREADY has internal
* representation of ByteCode and thus will not be compiled again
*/
| | < | 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 |
/*
* The bug trigger. Repeating the command but:
* - we are calling apply with a lambda that is a list (as BEFORE),
* BUT
* - The body of the lambda (lambdaObjs[1]) ALREADY has internal
* representation of ByteCode and thus will not be compiled again
*/
evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so no need for IncrRef */
result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(evalObjs[0]);
Tcl_DecrRefCount(lambdaObj);
return result;
}
|
| ︙ | ︙ |
Changes to generic/tclTestABSList.c.
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | my_LStringObjLength, /* Length */ my_LStringObjIndex, /* Index */ my_LStringObjRange, /* Slice */ my_LStringObjReverse, /* Reverse */ my_LStringGetElements, /* GetElements */ my_LStringObjSetElem, /* SetElement */ my_LStringReplace, /* Replace */ | | | | | | | | | | | | | | 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 |
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*1*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
NULL, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*2*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
NULL, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*3*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
NULL, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*4*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
NULL, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*5*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
NULL, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*6*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
NULL, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*7*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
NULL, /* Replace */
NULL) /* "in" operator */
},
{/*8*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*9*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
{/*10*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
}
};
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 | } /* *---------------------------------------------------------------------- * * my_LStringObjReverse -- * | | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 | } /* *---------------------------------------------------------------------- * * my_LStringObjReverse -- * * Creates a new Obj with the order of the elements in the lstring * value reversed, where first is last and last is first, etc. * * Results: * A new Obj is assigned to newObjPtr. Returns TCL_OK * * Side effects: * A new Obj is created. |
| ︙ | ︙ | |||
852 853 854 855 856 857 858 |
if (llen <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
}
for (bytesNeeded = 0, i = 0; i < llen; i++) {
| | | | | | | | | | 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 |
if (llen <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
}
for (bytesNeeded = 0, i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
typePtr->indexProc(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
/* Note TclScanElement updates flagPtr[i] */
bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
Tcl_DecrRefCount(elemObj);
}
if (bytesNeeded > INT_MAX - llen + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
bytesNeeded += llen; /* Separating spaces and terminating nul */
/*
* Pass 2: generate the string repr.
*/
objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
p = objPtr->bytes;
for (i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
typePtr->indexProc(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]);
*p++ = ' ';
Tcl_DecrRefCount(elemObj);
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
// EVAL DIRECT to avoid interfering with bytecode compile which may be
// active on the stack
int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT;
int status = Tcl_EvalObjEx(intrp, genCmd, flags);
elemObj = Tcl_GetObjResult(intrp);
if (status != TCL_OK) {
Tcl_SetObjResult(intrp, Tcl_ObjPrintf(
| | | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 |
// EVAL DIRECT to avoid interfering with bytecode compile which may be
// active on the stack
int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT;
int status = Tcl_EvalObjEx(intrp, genCmd, flags);
elemObj = Tcl_GetObjResult(intrp);
if (status != TCL_OK) {
Tcl_SetObjResult(intrp, Tcl_ObjPrintf(
"Error: %s\nwhile executing %s\n",
elemObj ? Tcl_GetString(elemObj) : "NULL", Tcl_GetString(genCmd)));
return NULL;
}
}
return elemObj;
}
|
| ︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 | static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); /* * Abstract List ObjType definition */ | | | | | | 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 |
static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
/*
* Abstract List ObjType definition
*/
static const Tcl_ObjType lgenType = {
"lgenseries",
FreeLgenInternalRep,
DupLgenSeriesRep,
UpdateStringOfLgen,
NULL, /* SetFromAnyProc */
TCL_OBJTYPE_V2(
lgenSeriesObjLength,
lgenSeriesObjIndex,
NULL, /* slice */
NULL, /* reverse */
NULL, /* get elements */
NULL, /* set element */
NULL, /* replace */
NULL) /* "in" operator */
};
/*
* ObjType Duplicate Internal Rep Function
*/
static void
DupLgenSeriesRep(
|
| ︙ | ︙ |
Changes to generic/tclTestObj.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef BUILD_tcl #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" #else # include "tclTomMath.h" #endif #include "tclStringRep.h" | > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef BUILD_tcl #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */ #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" #else # include "tclTomMath.h" #endif #include "tclStringRep.h" |
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | static Tcl_ObjCmdProc TestobjCmd; static Tcl_ObjCmdProc TeststringobjCmd; static Tcl_ObjCmdProc TestbigdataCmd; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 | > > > | > | > | > > | 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 |
static Tcl_ObjCmdProc TestobjCmd;
static Tcl_ObjCmdProc TeststringobjCmd;
static Tcl_ObjCmdProc TestbigdataCmd;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
static void
VarPtrDeleteProc(
void *clientData,
TCL_UNUSED(Tcl_Interp *))
{
int i;
Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i]) {
Tcl_DecrRefCount(varPtr[i]);
}
}
Tcl_Free(varPtr);
}
static Tcl_Obj **
GetVarPtr(
Tcl_Interp *interp)
{
Tcl_InterpDeleteProc *proc;
return (Tcl_Obj **) Tcl_GetAssocData(interp, VARPTR_KEY, &proc);
}
/*
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
/*
* An array of Tcl_Obj pointers used in the commands that operate on or get
* the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
* Tcl_Obj *.
*/
Tcl_Obj **varPtr;
| > > > > > | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
/*
* An array of Tcl_Obj pointers used in the commands that operate on or get
* the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
* Tcl_Obj *.
*/
Tcl_Obj **varPtr;
#ifndef TCL_WITH_EXTERNAL_TOMMATH
if (Tcl_TomMath_InitStubs(interp, "8.7-") == NULL) {
return TCL_ERROR;
}
#endif
varPtr = (Tcl_Obj **)Tcl_Alloc(NUMBER_OF_OBJECT_VARS * sizeof(varPtr[0]));
if (!varPtr) {
return TCL_ERROR;
}
Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr);
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
|
| ︙ | ︙ | |||
403 404 405 406 407 408 409 |
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
| | | | 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 |
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
&boolValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, or not", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
| | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
&doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue * 10.0));
}
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
| | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 |
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, mult10, or div10", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
821 822 823 824 825 826 827 |
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
| | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, get2, mult10, or div10", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_REPLACE:
if (objc < 5) {
Tcl_WrongNumArgs(interp, 2, objv,
| | | | 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 |
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_REPLACE:
if (objc < 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"varIndex start count ?element...?");
return TCL_ERROR;
}
if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK
|| Tcl_GetIntForIndex(interp, objv[4], TCL_INDEX_NONE, &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
case LISTOBJ_INDEXMEMCHECK:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varPtr, varIndex)) {
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 |
break;
case LISTOBJ_INDEX:
/*
* Tcl_ListObjIndex semantics differ from lindex for out of bounds.
* Hence this explicit test.
*/
if (objc != 4) {
| | < | 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 |
break;
case LISTOBJ_INDEX:
/*
* Tcl_ListObjIndex semantics differ from lindex for out of bounds.
* Hence this explicit test.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex listIndex");
return TCL_ERROR;
}
if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK) {
return TCL_ERROR;
} else {
Tcl_Obj *objP;
if (Tcl_ListObjIndex(interp, varPtr[varIndex], first, &objP) != TCL_OK) {
|
| ︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 |
} else {
const char *typeName;
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
| < < < < < | 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
} else {
const char *typeName;
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
}
return TCL_OK;
case TESTOBJ_NEWOBJ:
if (objc != 3) {
goto wrongNumArgs;
|
| ︙ | ︙ | |||
1231 1232 1233 1234 1235 1236 1237 |
break;
case TESTOBJ_CONVERT:
if (objc != 4) {
goto wrongNumArgs;
}
if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
| | | 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 |
break;
case TESTOBJ_CONVERT:
if (objc != 4) {
goto wrongNumArgs;
}
if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", Tcl_GetString(objv[3]), " found", (char *)NULL);
return TCL_ERROR;
}
if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 |
break;
case TESTOBJ_TYPE:
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
| < < < < < | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 |
break;
case TESTOBJ_TYPE:
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
break;
default:
break;
|
| ︙ | ︙ | |||
1388 1389 1390 1391 1392 1393 1394 |
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
| | | 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 |
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
strings[10], strings[11], (char *)NULL);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
|
| ︙ | ︙ | |||
1649 1650 1651 1652 1653 1654 1655 |
split = len - 1; /* Last position */
}
}
}
/* Need one byte for nul terminator */
Tcl_Size limit = TCL_SIZE_MAX-1;
if (len < 0 || len > limit) {
| | < < | < | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 |
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:
Tcl_DStringInit(&ds);
Tcl_DStringSetLength(&ds, len);/* Also stores \0 at index len+1 */
|
| ︙ | ︙ |
Changes to generic/tclTestProcBodyObj.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
int exportIt; /* if 1, export the command */
} CmdTable;
/*
* Declarations for functions defined in this file.
*/
| | | | | | | | 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 |
int exportIt; /* if 1, export the command */
} CmdTable;
/*
* Declarations for functions defined in this file.
*/
static Tcl_ObjCmdProc ProcBodyTestProcCmd;
static Tcl_ObjCmdProc ProcBodyTestCheckCmd;
static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int RegisterCommand(Tcl_Interp* interp,
const char *namesp, const CmdTable *cmdTablePtr);
/*
* List of commands to create when the package is loaded; must go after the
* declarations of the enable command procedure.
*/
static const CmdTable commands[] = {
{ procCommand, ProcBodyTestProcCmd, 1 },
{ checkCommand, ProcBodyTestCheckCmd, 1 },
{ 0, 0, 0 }
};
static const CmdTable safeCommands[] = {
{ procCommand, ProcBodyTestProcCmd, 1 },
{ checkCommand, ProcBodyTestCheckCmd, 1 },
{ 0, 0, 0 }
};
/*
*----------------------------------------------------------------------
*
* Procbodytest_Init --
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL);
}
/*
*----------------------------------------------------------------------
*
| | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL);
}
/*
*----------------------------------------------------------------------
*
* ProcBodyTestProcCmd --
*
* Implements the "procbodytest::proc" command. Here is the command
* description:
* procbodytest::proc newName argList bodyName
* Looks up a procedure called $bodyName and, if the procedure exists,
* constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
* Arguments:
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 | * A new procedure is created. * Leaves an error message in the interp's result on error. * *---------------------------------------------------------------------- */ static int | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
* A new procedure is created.
* Leaves an error message in the interp's result on error.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestProcCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
const char *fullName;
Tcl_Command procCmd;
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 |
/*
* check that this is a procedure and not a builtin command:
* If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr).
*/
if (cmdPtr->objClientData != TclIsProc(cmdPtr)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
| | | | | | | 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 |
/*
* check that this is a procedure and not a builtin command:
* If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr).
*/
if (cmdPtr->objClientData != TclIsProc(cmdPtr)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"command \"", fullName, "\" is not a Tcl procedure", (char *)NULL);
return TCL_ERROR;
}
/*
* it is a Tcl procedure: the client data is the Proc structure
*/
procPtr = (Proc *) cmdPtr->objClientData;
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"",
fullName, "\" does not have a Proc struct!", (char *)NULL);
return TCL_ERROR;
}
/*
* create a new object, initialize our argument vector, call into Tcl
*/
bodyObjPtr = TclNewProcBodyObj(procPtr);
if (bodyObjPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"failed to create a procbody object for procedure \"",
fullName, "\"", (char *)NULL);
return TCL_ERROR;
}
Tcl_IncrRefCount(bodyObjPtr);
myobjv[0] = objv[0];
myobjv[1] = objv[1];
myobjv[2] = objv[2];
myobjv[3] = bodyObjPtr;
myobjv[4] = NULL;
result = Tcl_ProcObjCmd(NULL, interp, objc, myobjv);
Tcl_DecrRefCount(bodyObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* ProcBodyTestCheckCmd --
*
* Implements the "procbodytest::check" command. Here is the command
* description:
* procbodytest::check
*
* Performs an internal check that the Tcl_PkgPresent() command returns
* the same version number as was registered when the tcl::procbodytest package
* was provided. Places a boolean in the interp result indicating the
* test outcome.
*
* Results:
* Returns a standard Tcl code.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestCheckCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
const char *version;
|
| ︙ | ︙ |
Changes to generic/tclThread.c.
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
RememberSyncObject(
void *objPtr, /* Pointer to sync object */
SyncObjRecord *recPtr) /* Record of sync objects */
{
void **newList;
int i, j;
| < | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
RememberSyncObject(
void *objPtr, /* Pointer to sync object */
SyncObjRecord *recPtr) /* Record of sync objects */
{
void **newList;
int i, j;
/*
* Reuse any free slot in the list.
*/
for (i=0 ; i < recPtr->num ; ++i) {
if (recPtr->list[i] == NULL) {
recPtr->list[i] = objPtr;
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 | * * Side effects: * All thread exit handlers are invoked, then the thread dies. * *---------------------------------------------------------------------- */ | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
*
* Side effects:
* All thread exit handlers are invoked, then the thread dies.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
Tcl_ExitThread(
int status)
{
Tcl_FinalizeThread();
TclpThreadExit(status);
}
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 | #define sourceBucket b.u.s.bucket #define magicNum1 b.u.s.magic1 #define magicNum2 b.u.s.magic2 #define MAGIC 0xEF #define blockReqSize b.reqSize /* | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | #define sourceBucket b.u.s.bucket #define magicNum1 b.u.s.magic1 #define magicNum2 b.u.s.magic2 #define MAGIC 0xEF #define blockReqSize b.reqSize /* * The following defines the minimum and maximum block sizes and the number * of buckets in the bucket cache. */ #define MINALLOC ((sizeof(Block) + 8 + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) #define NBUCKETS (11 - (MINALLOC >> 5)) #define MAXALLOC (MINALLOC << (NBUCKETS - 1)) |
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
cachePtr = (Cache*)TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache));
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
| | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
cachePtr = (Cache*)TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache));
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
memset(cachePtr, 0, sizeof(Cache));
Tcl_MutexLock(listLockPtr);
cachePtr->nextPtr = firstCachePtr;
firstCachePtr = cachePtr;
Tcl_MutexUnlock(listLockPtr);
cachePtr->owner = Tcl_GetCurrentThread();
TclpSetAllocCache(cachePtr);
}
|
| ︙ | ︙ |
Changes to generic/tclThreadTest.c.
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | /* * Access to the list of threads and to the thread send results is guarded by * this mutex. */ TCL_DECLARE_MUTEX(threadMutex) | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | /* * Access to the list of threads and to the thread send results is guarded by * this mutex. */ TCL_DECLARE_MUTEX(threadMutex) static Tcl_ObjCmdProc ThreadCmd; static int ThreadCreate(Tcl_Interp *interp, const char *script, int joinable); static int ThreadList(Tcl_Interp *interp); static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id, const char *script, int wait); static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id, const char *result, int flags); |
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
Tcl_MutexLock(&threadMutex);
if (mainThreadId == 0) {
mainThreadId = Tcl_GetCurrentThread();
}
Tcl_MutexUnlock(&threadMutex);
| | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
Tcl_MutexLock(&threadMutex);
if (mainThreadId == 0) {
mainThreadId = Tcl_GetCurrentThread();
}
Tcl_MutexUnlock(&threadMutex);
Tcl_CreateObjCommand(interp, "testthread", ThreadCmd, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadCmd --
*
* This procedure is invoked to process the "testthread" Tcl command. See
* the user documentation for details on what it does.
*
* thread cancel ?-unwind? id ?result?
* thread create ?-joinable? ?script?
* thread send ?-async? id script
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
static const char *const threadOptions[] = {
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
result = Tcl_JoinThread((Tcl_ThreadId)INT2PTR(id), &status);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
} else {
char buf[TCL_INTEGER_SPACE];
snprintf(buf, sizeof(buf), "%" TCL_LL_MODIFIER "d", (long long)id);
| | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
result = Tcl_JoinThread((Tcl_ThreadId)INT2PTR(id), &status);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
} else {
char buf[TCL_INTEGER_SPACE];
snprintf(buf, sizeof(buf), "%" TCL_LL_MODIFIER "d", (long long)id);
Tcl_AppendResult(interp, "cannot join thread ", buf, (char *)NULL);
}
return result;
}
case THREAD_NAMES:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 |
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
| | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "cannot create a new thread", (char *)NULL);
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using something on our stack!
*/
|
| ︙ | ︙ | |||
816 817 818 819 820 821 822 |
if (tsdPtr->threadId == threadId) {
found = 1;
break;
}
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
| | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
if (tsdPtr->threadId == threadId) {
found = 1;
break;
}
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "invalid thread id", (char *)NULL);
return TCL_ERROR;
}
/*
* Short circuit sends to ourself. Ought to do something with -async, like
* run in an idle handler.
*/
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 |
resultPtr->nextPtr = NULL;
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
| | | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 |
resultPtr->nextPtr = NULL;
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, (char *)NULL);
Tcl_Free(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
Tcl_Free(resultPtr->errorInfo);
}
}
Tcl_AppendResult(interp, resultPtr->result, (char *)NULL);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
Tcl_Free(resultPtr->result);
Tcl_Free(resultPtr);
return code;
|
| ︙ | ︙ | |||
969 970 971 972 973 974 975 |
if (tsdPtr->threadId == threadId) {
found = 1;
break;
}
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
| | | | 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 |
if (tsdPtr->threadId == threadId) {
found = 1;
break;
}
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "invalid thread id", (char *)NULL);
return TCL_ERROR;
}
/*
* Since Tcl_CancelEval can be safely called from any thread,
* we do it now.
*/
Tcl_MutexUnlock(&threadMutex);
Tcl_ResetResult(interp);
return Tcl_CancelEval(tsdPtr->interp,
(result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
}
/*
*------------------------------------------------------------------------
*
* ThreadEventProc --
*
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
| ︙ | ︙ | |||
819 820 821 822 823 824 825 |
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(
| | | | | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
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));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, (char *)NULL);
return TCL_ERROR;
}
}
/*
* At this point, either index = -1 and ms contains the number of ms
* to wait, or else index is the index of a subcommand.
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
| | | | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, length)) {
break;
}
}
if (afterPtr == NULL) {
|
| ︙ | ︙ | |||
948 949 950 951 952 953 954 |
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
"after#%d", afterPtr->id));
}
}
| | | | | | | 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 |
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
"after#%d", afterPtr->id));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (char *)NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr;
TclNewObj(resultListPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
afterPtr->commandPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(afterPtr->token == NULL) ? "idle" : "timer", -1));
Tcl_SetObjResult(interp, resultListPtr);
}
break;
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 |
}
if (iPtr->limit.timeEvent == NULL
|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
| | | | | | | | | | 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 |
}
if (iPtr->limit.timeEvent == NULL
|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
diff = 1;
}
if (diff > 0) {
Tcl_Sleep((int) diff);
if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
break;
}
} else {
break;
}
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff > 0) {
Tcl_Sleep((int) diff);
|
| ︙ | ︙ |
Changes to generic/tclTomMath.decls.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
}
declare 15 {
mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
| < < < < | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
}
declare 15 {
mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
declare 18 {
void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
mp_err MP_WUR TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c)
}
declare 20 {
mp_err MP_WUR TclBN_mp_grow(mp_int *a, int size)
}
declare 21 {
mp_err MP_WUR TclBN_mp_init(mp_int *a)
}
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
}
declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
declare 38 {
mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
}
declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
declare 38 {
mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
declare 41 {
mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 43 {
mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
}
declare 47 {
size_t MP_WUR TclBN_mp_ubin_size(const mp_int *a)
}
declare 48 {
mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
}
declare 63 {
int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a)
}
declare 65 {
int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal)
}
declare 66 {
int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal)
}
declare 68 {
void TclBN_mp_set_u64(mp_int *a, uint64_t i)
}
declare 69 {
uint64_t MP_WUR TclBN_mp_get_mag_u64(const mp_int *a)
}
declare 70 {
void TclBN_mp_set_i64(mp_int *a, int64_t i)
}
declare 71 {
mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
mp_endian endian, size_t nails, const void *op)
}
declare 72 {
mp_err MP_WUR TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
size_t size, mp_endian endian, size_t nails, const mp_int *op)
}
declare 76 {
mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
declare 77 {
size_t MP_WUR TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size)
}
# Added in libtommath 1.2.0
declare 78 {
int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
}
declare 80 {
int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclTomMathDecls.h.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
# define MODULE_SCOPE extern
# endif
#endif
#ifdef __cplusplus
extern "C" {
#endif
| | < > | | | | | | | 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 |
# define MODULE_SCOPE extern
# endif
#endif
#ifdef __cplusplus
extern "C" {
#endif
MODULE_SCOPE mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b);
MODULE_SCOPE mp_err TclBN_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c);
MODULE_SCOPE mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, mp_digit *d);
MODULE_SCOPE mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c);
MODULE_SCOPE mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b);
MODULE_SCOPE mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c);
MODULE_SCOPE mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b);
MODULE_SCOPE mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c);
MODULE_SCOPE mp_err TclBN_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
MODULE_SCOPE mp_err TclBN_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs);
MODULE_SCOPE void TclBN_mp_reverse(unsigned char *s, size_t len);
MODULE_SCOPE mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b);
MODULE_SCOPE mp_err TclBN_mp_sqr_fast(const mp_int *a, mp_int *b);
MODULE_SCOPE mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c);
MODULE_SCOPE const char *const TclBN_mp_s_rmap;
MODULE_SCOPE const uint8_t TclBN_mp_s_rmap_reverse[];
MODULE_SCOPE const size_t TclBN_mp_s_rmap_reverse_sz;
MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b);
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 | #define mp_cmp_mag TclBN_mp_cmp_mag #define mp_cnt_lsb TclBN_mp_cnt_lsb #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits #define mp_div TclBN_mp_div #define mp_div_d TclBN_mp_div_d #define mp_div_2 TclBN_mp_div_2 | < | < | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | #define mp_cmp_mag TclBN_mp_cmp_mag #define mp_cnt_lsb TclBN_mp_cnt_lsb #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits #define mp_div TclBN_mp_div #define mp_div_d TclBN_mp_div_d #define mp_div_2 TclBN_mp_div_2 #define mp_div_2d TclBN_mp_div_2d #define mp_exch TclBN_mp_exch #define mp_expt_d TclBN_mp_expt_n #define mp_expt_n TclBN_mp_expt_n #define mp_get_mag_u64 TclBN_mp_get_mag_u64 #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy #define mp_init_i64 TclBN_mp_init_i64 #define mp_init_multi TclBN_mp_init_multi #define mp_init_set TclBN_mp_init_set |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 | #define mp_pack_count TclBN_mp_pack_count #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd #define mp_s_rmap TclBN_mp_s_rmap #define mp_s_rmap_reverse TclBN_mp_s_rmap_reverse #define mp_s_rmap_reverse_sz TclBN_mp_s_rmap_reverse_sz | | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | #define mp_pack_count TclBN_mp_pack_count #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd #define mp_s_rmap TclBN_mp_s_rmap #define mp_s_rmap_reverse TclBN_mp_s_rmap_reverse #define mp_s_rmap_reverse_sz TclBN_mp_s_rmap_reverse_sz #define mp_set TclBN_mp_set #define mp_set_i64 TclBN_mp_set_i64 #define mp_set_u64 TclBN_mp_set_u64 #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt #define mp_sub TclBN_mp_sub #define mp_sub_d TclBN_mp_sub_d |
| ︙ | ︙ | |||
156 157 158 159 160 161 162 163 164 | #define mp_to_ubin TclBN_mp_to_ubin #define mp_ubin_size TclBN_mp_ubin_size #define mp_unpack TclBN_mp_unpack #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add #define s_mp_balance_mul TclBN_mp_balance_mul #define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul #define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr | > | | | | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | #define mp_to_ubin TclBN_mp_to_ubin #define mp_ubin_size TclBN_mp_ubin_size #define mp_unpack TclBN_mp_unpack #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add #define s_mp_balance_mul TclBN_mp_balance_mul #define s_mp_div_3 TclBN_mp_div_3 #define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul #define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define s_mp_mul_digs TclBN_mp_mul_digs #define s_mp_mul_digs_fast TclBN_mp_mul_digs_fast #define s_mp_reverse TclBN_mp_reverse #define s_mp_sqr TclBN_s_mp_sqr #define s_mp_sqr_fast TclBN_mp_sqr_fast #define s_mp_sub TclBN_s_mp_sub #define s_mp_toom_mul TclBN_mp_toom_mul #define s_mp_toom_sqr TclBN_mp_toom_sqr #endif /* !TCL_WITH_EXTERNAL_TOMMATH */ #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl |
| ︙ | ︙ | |||
239 240 241 242 243 244 245 | /* 16 */ EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* Slot 17 is reserved */ /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); /* 19 */ | | < | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | /* 16 */ EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* Slot 17 is reserved */ /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); /* 19 */ EXTERN mp_err TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c) MP_WUR; /* 20 */ EXTERN mp_err TclBN_mp_grow(mp_int *a, int size) MP_WUR; /* 21 */ EXTERN mp_err TclBN_mp_init(mp_int *a) MP_WUR; /* 22 */ EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) MP_WUR; /* 23 */ |
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */
mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */
mp_err (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) MP_WUR; /* 14 */
mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */
mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */
void (*reserved17)(void);
void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
| | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 |
int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */
mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */
mp_err (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) MP_WUR; /* 14 */
mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */
mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */
void (*reserved17)(void);
void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
mp_err (*tclBN_mp_expt_n) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 19 */
mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */
mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */
mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */
mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */
mp_err (*tclBN_mp_init_set) (mp_int *a, mp_digit b) MP_WUR; /* 24 */
mp_err (*tclBN_mp_init_size) (mp_int *a, int size) MP_WUR; /* 25 */
mp_err (*tclBN_mp_lshd) (mp_int *a, int shift) MP_WUR; /* 26 */
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 | #define TclBN_mp_div_2 \ (tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */ #define TclBN_mp_div_2d \ (tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */ /* Slot 17 is reserved */ #define TclBN_mp_exch \ (tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */ | | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 | #define TclBN_mp_div_2 \ (tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */ #define TclBN_mp_div_2d \ (tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */ /* Slot 17 is reserved */ #define TclBN_mp_exch \ (tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */ #define TclBN_mp_expt_n \ (tclTomMathStubsPtr->tclBN_mp_expt_n) /* 19 */ #define TclBN_mp_grow \ (tclTomMathStubsPtr->tclBN_mp_grow) /* 20 */ #define TclBN_mp_init \ (tclTomMathStubsPtr->tclBN_mp_init) /* 21 */ #define TclBN_mp_init_copy \ (tclTomMathStubsPtr->tclBN_mp_init_copy) /* 22 */ #define TclBN_mp_init_multi \ |
| ︙ | ︙ |
Changes to generic/tclTomMathStubLib.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #include "tclInt.h" #include "tclTomMath.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; const TclTomMathStubs *tclTomMathStubsPtr = NULL; | < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | #include "tclInt.h" #include "tclTomMath.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; const TclTomMathStubs *tclTomMathStubsPtr = NULL; /* *---------------------------------------------------------------------- * * TclTomMathInitStubs -- * * Initializes the Stubs table for Tcl's subset of libtommath |
| ︙ | ︙ |
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
306 307 308 309 310 311 312 | } /* * Make sure the ops argument is a list object; get its length and a * pointer to its array of element pointers. */ | | | | | 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 |
}
/*
* Make sure the ops argument is a list object; get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjLength(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" enter, leave, enterstep, or leavestep", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
(char *)NULL);
return TCL_ERROR;
}
result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
342 343 344 345 346 347 348 | flags |= TCL_TRACE_ENTER_DURING_EXEC; break; case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; } } | | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
flags |= TCL_TRACE_ENTER_DURING_EXEC;
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = TclGetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
TclNewLiteralStringObj(opObj, "enterstep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
TclNewLiteralStringObj(opObj, "leavestep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
| | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
TclNewLiteralStringObj(opObj, "enterstep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
TclNewLiteralStringObj(opObj, "leavestep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
TclListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 | } /* * Make sure the ops argument is a list object; get its length and a * pointer to its array of element pointers. */ | | | | | | 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 |
}
/*
* Make sure the ops argument is a list object; get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjLength(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" delete or rename", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
(char *)NULL);
return TCL_ERROR;
}
result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case TRACE_CMD_RENAME:
flags |= TCL_TRACE_RENAME;
break;
case TRACE_CMD_DELETE:
flags |= TCL_TRACE_DELETE;
break;
}
}
command = TclGetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
TclNewLiteralStringObj(opObj, "rename");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
if (tcmdPtr->flags & TCL_TRACE_DELETE) {
TclNewLiteralStringObj(opObj, "delete");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
| | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 |
TclNewLiteralStringObj(opObj, "rename");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
if (tcmdPtr->flags & TCL_TRACE_DELETE) {
TclNewLiteralStringObj(opObj, "delete");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
TclListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 | } /* * Make sure the ops argument is a list object; get its length and a * pointer to its array of element pointers. */ | | | | | 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 |
}
/*
* Make sure the ops argument is a list object; get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjLength(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" array, read, unset, or write", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
(char *)NULL);
return TCL_ERROR;
}
result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
for (i = 0; i < listLen ; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 | flags |= TCL_TRACE_UNSETS; break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } | | | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 |
flags |= TCL_TRACE_UNSETS;
break;
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
command = TclGetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc(
offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
ctvarPtr->traceCmdInfo.length = length;
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 |
if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){
Interp *iPtr = (Interp *) interp;
iPtr->compileEpoch++;
}
cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
}
| < | 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 |
if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){
Interp *iPtr = (Interp *) interp;
iPtr->compileEpoch++;
}
cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceCommand --
|
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 | /* * None of the remaining traces on this command are execution traces. * We therefore remove this flag: */ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; | | | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 |
/*
* None of the remaining traces on this command are execution traces.
* We therefore remove this flag:
*/
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
/*
* Bug 3484621: up the interp's epoch if this is a BC'ed command
*/
if (cmdPtr->compileProc != NULL) {
iPtr->compileEpoch++;
}
}
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
if (tracePtr->level > 0 && curLevel > tracePtr->level) {
continue;
}
if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
/*
| | | 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 |
if (tracePtr->level > 0 && curLevel > tracePtr->level) {
continue;
}
if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
/*
* The proc invoked might delete the traced command which
* might try to free tracePtr. We want to use tracePtr until the
* end of this if section, so we use Tcl_Preserve() and
* Tcl_Release() to be sure it is not freed while we still need
* it.
*/
Tcl_Preserve(tracePtr);
|
| ︙ | ︙ | |||
1981 1982 1983 1984 1985 1986 1987 |
typedef struct {
Tcl_CmdObjTraceProc *proc;
Tcl_CmdObjTraceDeleteProc *delProc;
void *clientData;
} TraceWrapperInfo;
| | > > | > | 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 |
typedef struct {
Tcl_CmdObjTraceProc *proc;
Tcl_CmdObjTraceDeleteProc *delProc;
void *clientData;
} TraceWrapperInfo;
static int
traceWrapperProc(
void *clientData,
Tcl_Interp *interp,
Tcl_Size level,
const char *command,
Tcl_Command commandInfo,
Tcl_Size objc,
Tcl_Obj *const objv[])
{
TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
if (objc > INT_MAX) {
objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */
}
return info->proc(info->clientData, interp, (int)level, command, commandInfo, objc, objv);
}
static void
traceWrapperDelProc(
void *clientData)
{
TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
clientData = info->clientData;
if (info->delProc) {
info->delProc(clientData);
}
Tcl_Free(info);
|
| ︙ | ︙ | |||
2392 2393 2394 2395 2396 2397 2398 |
Var *arrayPtr,
Tcl_Obj *name,
int index)
{
int code = TCL_OK;
if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
| | | 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 |
Var *arrayPtr,
Tcl_Obj *name,
int index)
{
int code = TCL_OK;
if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
Interp *iPtr = (Interp *)interp;
code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL,
(TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY),
/* leaveErrMsg */ 1, index);
}
return code;
|
| ︙ | ︙ | |||
2541 2542 2543 2544 2545 2546 2547 |
}
}
}
/* Keep the original pointer for possible use in an error message */
element = part2;
if (part2 == NULL) {
| | | | | | | | | | | 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 |
}
}
}
/* Keep the original pointer for possible use in an error message */
element = part2;
if (part2 == NULL) {
if (TclIsVarArrayElement(varPtr)) {
Tcl_Obj *keyObj = VarHashGetKey(varPtr);
part2 = Tcl_GetString(keyObj);
}
} else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) {
/* On unset traces, part2 has already been set by the caller, and
* the VAR_ARRAY_ELEMENT flag indicates whether the accessed
* variable actually has a second part, or is a scalar */
element = NULL;
}
/*
* Invoke traces on the array containing the variable, if relevant.
*/
result = NULL;
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve(iPtr);
if (arrayPtr && !TclIsVarTraceActive(arrayPtr)
&& (arrayPtr->flags & traceflags)) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, arrayPtr);
active.varPtr = arrayPtr;
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
|
| ︙ | ︙ | |||
2604 2605 2606 2607 2608 2609 2610 |
*/
if (flags & TCL_TRACE_UNSETS) {
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
| | | 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 |
*/
if (flags & TCL_TRACE_UNSETS) {
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve(tracePtr);
|
| ︙ | ︙ | |||
2801 2802 2803 2804 2805 2806 2807 |
* interested in now.
*/
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
flags &= flagMask;
| | | 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 |
* interested in now.
*/
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
flags &= flagMask;
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
goto updateFlags;
}
if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
&& (tracePtr->clientData == clientData)) {
|
| ︙ | ︙ | |||
2915 2916 2917 2918 2919 2920 2921 |
return NULL;
}
/*
* Find the relevant trace, if any, and return its clientData.
*/
| | | 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 |
return NULL;
}
/*
* Find the relevant trace, if any, and return its clientData.
*/
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
if (hPtr) {
VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
if (prevClientData != NULL) {
for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
|
| ︙ | ︙ |
Changes to generic/tclUniData.c.
| ︙ | ︙ | |||
196 197 198 199 200 201 202 |
10304, 10336, 10368, 1344, 1344, 1344, 10400, 10432, 64, 10464, 10496,
10528, 4736, 10560, 10592
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,10624, 10656, 10688, 3296, 1344, 1344, 1344, 10720, 10752, 10784,
10816, 10848, 10880, 10912, 8032, 10944, 3296, 3296, 3296, 3296, 9216,
1344, 10976, 11008, 1344, 11040, 11072, 11104, 11136, 1344, 11168,
3296, 11200, 11232, 11264, 1344, 11296, 11328, 11360, 11392, 1344,
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | > > > > > > > > > > > > > > > > > > > > | | > > > > > > | | | | > > > > > > > > > > > > | > > > > > | | > | | | > > > | > > | > > | > > > > > > > > | > > | | | < < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < | < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
10304, 10336, 10368, 1344, 1344, 1344, 10400, 10432, 64, 10464, 10496,
10528, 4736, 10560, 10592
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,10624, 10656, 10688, 3296, 1344, 1344, 1344, 10720, 10752, 10784,
10816, 10848, 10880, 10912, 8032, 10944, 3296, 3296, 3296, 3296, 9216,
1344, 10976, 11008, 1344, 11040, 11072, 11104, 11136, 1344, 11168,
3296, 11200, 11232, 11264, 1344, 11296, 11328, 11360, 11392, 1344,
11424, 1344, 11456, 11488, 11520, 1344, 11552, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 7776, 4704, 11584, 11616, 11648, 3296,
3296, 11680, 11712, 11744, 11776, 4736, 11808, 3296, 11840, 11872,
11904, 3296, 3296, 1344, 11936, 11968, 6880, 12000, 12032, 12064, 12096,
12128, 3296, 12160, 12192, 1344, 12224, 12256, 12288, 12320, 12352,
3296, 3296, 1344, 1344, 12384, 3296, 12416, 12448, 12480, 12512, 1344,
12544, 12576, 12608, 12640, 3296, 3296, 3296, 3296, 3296, 3296, 12672,
1344, 12704, 12736, 12768, 12128, 12800, 12832, 12864, 12896, 12864,
12928, 7776, 12960, 12992, 13024, 13056, 5280, 13088, 13120, 13152,
13184, 13216, 13248, 13280, 5280, 13312, 13344, 13376, 13408, 13440,
13472, 3296, 13504, 13536, 13568, 13600, 13632, 13664, 13696, 13728,
13760, 13792, 13824, 13856, 1344, 13888, 13920, 13952, 1344, 13984,
14016, 3296, 3296, 3296, 3296, 3296, 1344, 14048, 14080, 3296, 1344,
14112, 14144, 14176, 1344, 14208, 14240, 14272, 14304, 14336, 14368,
3296, 3296, 3296, 3296, 3296, 1344, 14400, 3296, 3296, 3296, 14432,
14464, 14496, 14528, 14560, 14592, 3296, 3296, 14624, 14656, 14688,
14720, 14752, 14784, 1344, 14816, 14848, 1344, 4608, 14880, 3296, 3296,
3296, 3296, 3296, 1344, 14912, 14944, 14976, 15008, 15040, 15072, 15104,
3296, 3296, 15136, 15168, 15200, 15232, 15264, 15296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 15328, 15360, 15392, 15424, 3296,
3296, 15456, 15488, 15520, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 9920, 3296, 3296,
3296, 10816, 10816, 10816, 15552, 1344, 1344, 1344, 1344, 1344, 1344,
15584, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12864,
1344, 1344, 15616, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 15648, 15680, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 10720, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 14368, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 15712, 15744, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 4608, 4736, 15776, 1344, 4736, 15808,
15840, 1344, 15872, 15904, 15936, 15968, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 16000, 16032, 3296,
3296, 3296, 3296, 3296, 3296, 14432, 14464, 16064, 3296, 3296, 3296,
1344, 1344, 16096, 16128, 16160, 3296, 3296, 16192, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 16224, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
4704, 16256, 12384, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 16288, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 16320, 16352, 16384, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 9792, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344,
16416, 16448, 16480, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 16512, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 7968, 3296, 3296, 704, 16544, 16576, 4928,
4928, 4928, 16608, 3296, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
8000, 4928, 16640, 4928, 16672, 16704, 16736, 4928, 6848, 4928, 4928,
16768, 3296, 3296, 3296, 16800, 16800, 4928, 4928, 16832, 16864, 3296,
3296, 3296, 3296, 16896, 16928, 16960, 16992, 17024, 17056, 17088,
17120, 17152, 17184, 17216, 17248, 17280, 16896, 16928, 17312, 16992,
17344, 17376, 17408, 17120, 17440, 17472, 17504, 17536, 17568, 17600,
17632, 17664, 17696, 17728, 17760, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 704, 17792,
704, 17824, 17856, 17888, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 17920, 17952, 3296, 3296, 3296, 3296, 3296, 3296,
17984, 18016, 5664, 18048, 18080, 3296, 3296, 3296, 1344, 18112, 18144,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12864, 18176,
1344, 18208, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 12864, 18240, 3296, 3296, 3296, 3296,
3296, 3296, 12864, 18272, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 18304, 1344, 1344,
1344, 1344, 1344, 1344, 18336, 3296, 18368, 18400, 18432, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 18464,
6880, 18496, 3296, 3296, 18528, 18560, 3296, 3296, 3296, 3296, 3296,
3296, 18592, 18624, 18656, 18688, 18720, 18752, 3296, 18784, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 4928, 18816, 4928, 4928,
7968, 18848, 18880, 8000, 18912, 4928, 4928, 4928, 4928, 18944, 3296,
18976, 19008, 19040, 19072, 19104, 3296, 3296, 3296, 3296, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 19136, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 19168, 19200, 4928, 4928, 4928, 19232,
4928, 4928, 19264, 19296, 18816, 4928, 19328, 4928, 19360, 19392, 19424,
3296, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7968,
19456, 19488, 4928, 19520, 19552, 4928, 4928, 4928, 4928, 19584, 4928,
4928, 16512, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 3296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
9920, 1344, 1344, 1344, 1344, 1344, 1344, 11296, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 19616, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 19648, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
11296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1792, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15968
#endif /* TCL_UTF_MAX > 3 */
};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 25, 26, 23, 24, 23,
24, 23, 24, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 27,
23, 24, 23, 24, 23, 24, 28, 29, 30, 23, 24, 23, 24, 31, 23, 24, 32,
32, 23, 24, 21, 33, 34, 35, 23, 24, 32, 36, 37, 38, 39, 23, 24, 40,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 25, 26, 23, 24, 23,
24, 23, 24, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 27,
23, 24, 23, 24, 23, 24, 28, 29, 30, 23, 24, 23, 24, 31, 23, 24, 32,
32, 23, 24, 21, 33, 34, 35, 23, 24, 32, 36, 37, 38, 39, 23, 24, 40,
41, 38, 42, 43, 44, 23, 24, 23, 24, 23, 24, 45, 23, 24, 45, 21, 21,
23, 24, 45, 23, 24, 46, 46, 23, 24, 23, 24, 47, 23, 24, 21, 15, 23,
24, 21, 48, 15, 15, 15, 15, 49, 50, 51, 49, 50, 51, 49, 50, 51, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 52, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
21, 49, 50, 51, 23, 24, 53, 54, 23, 24, 23, 24, 23, 24, 23, 24, 55,
21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 21, 21, 21, 21, 21, 21, 56, 23, 24, 57, 58, 59, 59, 23, 24,
60, 61, 62, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 63, 64, 65, 66,
67, 21, 68, 68, 21, 69, 21, 70, 71, 21, 21, 21, 68, 72, 21, 73, 74,
75, 76, 21, 77, 78, 76, 79, 80, 21, 21, 78, 21, 81, 82, 21, 21, 83,
21, 21, 21, 21, 21, 21, 21, 84, 21, 21, 85, 21, 86, 85, 21, 21, 21,
87, 85, 88, 89, 89, 90, 21, 21, 21, 21, 21, 91, 21, 15, 21, 21, 21,
21, 21, 21, 21, 21, 92, 93, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 11, 11, 11, 11, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 94, 94, 94, 94, 94, 11, 11, 11, 11, 11, 11, 11, 94,
11, 94, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 96, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 23, 24, 23,
24, 94, 11, 23, 24, 0, 0, 94, 43, 43, 43, 3, 97, 0, 0, 0, 0, 11, 11,
98, 3, 99, 99, 99, 0, 100, 0, 101, 101, 21, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10,
10, 10, 10, 10, 102, 103, 103, 103, 21, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 104, 13, 13, 13, 13, 13, 13,
13, 13, 13, 105, 106, 106, 107, 108, 109, 110, 110, 110, 111, 112,
113, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 114, 115, 116, 117, 118, 119, 7, 23,
24, 120, 23, 24, 21, 55, 55, 55, 121, 121, 121, 121, 121, 121, 121,
121, 121, 121, 121, 121, 121, 121, 121, 121, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 115, 115, 115, 115, 115, 115, 115, 115,
115, 115, 115, 115, 115, 115, 115, 115, 23, 24, 14, 95, 95, 95, 95,
95, 122, 122, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 123, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 124, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 0, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 0, 0, 94, 3, 3, 3, 3, 3, 3, 21, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 21, 21, 3, 8, 0, 0, 14, 14, 4, 0, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 8, 95, 3, 95, 95, 3, 95, 95, 3, 95, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 15, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17,
17, 17, 17, 7, 7, 7, 3, 3, 4, 3, 3, 14, 14, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 3, 17, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 94, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15,
95, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 3, 15, 95, 95, 95, 95, 95, 95, 95, 17, 14, 95, 95, 95, 95,
95, 95, 94, 94, 95, 95, 14, 95, 95, 95, 95, 15, 15, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 15, 15, 15, 14, 14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 0, 17, 15, 95, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 15,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
95, 95, 95, 95, 95, 95, 95, 95, 95, 94, 94, 14, 3, 3, 3, 94, 0, 0,
95, 4, 4, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 95, 94, 95, 95, 95, 95, 95,
95, 95, 95, 95, 94, 95, 95, 95, 94, 95, 95, 95, 95, 95, 0, 0, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 95, 95, 95, 0, 0, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 15, 15, 15, 15,
15, 15, 0, 17, 17, 0, 0, 0, 0, 0, 95, 95, 95, 95, 95, 95, 95, 95, 95,
15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
17, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 127,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 95, 127, 95, 15, 127, 127, 127, 95, 95, 95, 95, 95, 95,
95, 95, 127, 127, 127, 127, 95, 127, 127, 15, 95, 95, 95, 95, 95, 95,
95, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 3, 3, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 3, 94, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 95, 127, 127, 0, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 0, 15, 0, 0, 0, 15, 15, 15, 15, 0, 0, 95, 15, 127, 127, 127, 95,
95, 95, 95, 0, 0, 127, 127, 0, 0, 127, 127, 95, 15, 0, 0, 0, 0, 0,
0, 0, 0, 127, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 95, 95, 0, 0, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4,
15, 3, 95, 0, 0, 95, 95, 127, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15,
15, 0, 15, 15, 0, 15, 15, 0, 0, 95, 0, 127, 127, 127, 95, 95, 0, 0,
0, 0, 95, 95, 0, 0, 95, 95, 95, 0, 0, 0, 95, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 95, 95, 15, 15, 15, 95, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 95,
127, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15,
15, 15, 0, 0, 95, 15, 127, 127, 127, 95, 95, 95, 95, 95, 0, 95, 95,
127, 0, 127, 127, 95, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 95, 95, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4,
0, 0, 0, 0, 0, 0, 0, 15, 95, 95, 95, 95, 95, 95, 0, 95, 127, 127, 0,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15,
0, 0, 95, 15, 127, 95, 127, 95, 95, 95, 95, 0, 0, 127, 127, 0, 0, 127,
127, 95, 0, 0, 0, 0, 0, 0, 0, 95, 95, 127, 0, 0, 0, 0, 15, 15, 0, 15,
15, 15, 95, 95, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, 18, 18,
18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 15, 0, 15, 15, 15,
15, 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, 15, 15,
0, 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 127, 127, 95,
127, 127, 0, 0, 0, 127, 127, 127, 0, 127, 127, 127, 95, 0, 0, 15, 0,
0, 0, 0, 0, 0, 127, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14, 4, 14,
0, 0, 0, 0, 0, 95, 127, 127, 127, 95, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 95, 15, 95, 95, 95, 127,
127, 127, 127, 0, 95, 95, 95, 0, 95, 95, 95, 95, 0, 0, 0, 0, 0, 0,
0, 95, 95, 0, 15, 15, 15, 0, 0, 15, 0, 0, 15, 15, 95, 95, 0, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 3, 18, 18, 18, 18,
18, 18, 18, 14, 15, 95, 127, 127, 3, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 95, 15, 127, 95, 127,
127, 127, 127, 127, 0, 95, 127, 127, 0, 127, 127, 95, 95, 0, 0, 0,
0, 0, 0, 0, 127, 127, 0, 0, 0, 0, 0, 0, 15, 15, 0, 15, 15, 95, 95,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 127, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 95, 95, 127, 127, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 15, 127,
127, 127, 95, 95, 95, 95, 0, 127, 127, 127, 0, 127, 127, 127, 95, 15,
14, 0, 0, 0, 0, 15, 15, 15, 127, 18, 18, 18, 18, 18, 18, 18, 15, 15,
15, 95, 95, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18,
18, 18, 18, 18, 14, 15, 15, 15, 15, 15, 15, 0, 95, 127, 127, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 95, 0, 0,
0, 0, 127, 127, 127, 95, 95, 95, 0, 95, 0, 127, 127, 127, 127, 127,
127, 127, 127, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
127, 127, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 15, 15, 95, 95, 95, 95, 95,
95, 95, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 94, 95, 95, 95, 95,
95, 95, 95, 95, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 15, 0, 15, 15, 15, 15, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 95, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 15, 0,
0, 15, 15, 15, 15, 15, 0, 94, 0, 95, 95, 95, 95, 95, 95, 95, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15, 15, 15, 15, 14, 14, 14, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 3, 14, 14, 14, 95, 95,
14, 14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 14, 95, 14, 95, 14, 95, 5, 6, 5, 6, 127, 127,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 127, 95, 95, 95, 95, 95,
3, 95, 95, 15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 0, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 0, 14, 14, 14, 14, 14, 14, 14, 14, 95, 14, 14,
14, 14, 14, 14, 0, 14, 14, 3, 3, 3, 3, 3, 14, 14, 14, 14, 3, 3, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 95,
95, 95, 95, 127, 95, 95, 95, 95, 95, 95, 127, 95, 95, 127, 127, 95,
95, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15,
15, 15, 15, 127, 127, 95, 95, 15, 15, 15, 15, 95, 95, 95, 15, 127,
127, 127, 15, 15, 127, 127, 127, 127, 127, 127, 127, 15, 15, 15, 95,
95, 95, 95, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95,
127, 127, 95, 95, 127, 127, 127, 127, 127, 127, 95, 15, 127, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 127, 127, 127, 95, 14, 14, 128, 128, 128, 128,
128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128,
128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128,
128, 128, 128, 128, 128, 128, 0, 128, 0, 0, 0, 0, 0, 128, 0, 0, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
3, 94, 129, 129, 129, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15,
15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 95, 95, 95, 3, 3, 3, 3, 3, 3, 3, 3, 3, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 130, 130, 130, 130,
130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130,
130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130,
130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130, 130,
130, 130, 107, 107, 107, 107, 107, 107, 0, 0, 113, 113, 113, 113, 113,
113, 0, 0, 8, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 3, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 2, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 5, 6, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 3, 3, 3, 131, 131, 131, 15, 15, 15, 15, 15,
15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 127, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 95, 95, 127, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
95, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 95, 95, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 127, 95, 95, 95, 95, 95, 95,
95, 127, 127, 127, 127, 127, 127, 127, 127, 95, 127, 127, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 3, 3, 3, 94, 3, 3, 3, 4, 15, 95, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 8, 3, 3,
3, 3, 95, 95, 95, 17, 95, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0,
0, 0, 15, 15, 15, 94, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
95, 95, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 95, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
95, 95, 95, 127, 127, 127, 127, 95, 95, 127, 127, 127, 0, 0, 0, 0,
127, 127, 95, 127, 127, 127, 127, 127, 127, 95, 95, 95, 0, 0, 0, 0,
14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
95, 95, 127, 127, 95, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 95, 127, 95, 95,
95, 95, 95, 95, 95, 0, 95, 127, 95, 127, 127, 95, 95, 95, 95, 95, 95,
95, 95, 127, 127, 127, 127, 127, 127, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 0, 0, 95, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 94,
3, 3, 3, 3, 3, 3, 0, 0, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 122, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95,
95, 95, 95, 127, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
95, 127, 95, 95, 95, 95, 95, 127, 95, 127, 127, 127, 127, 127, 95,
127, 127, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 3, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 95, 95, 95, 95, 95, 95, 95, 95, 95, 14, 14, 14, 14, 14, 14, 14,
14, 14, 3, 3, 3, 95, 95, 127, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 127, 95, 95, 95, 95, 127, 127, 95, 95, 127, 95, 95, 95,
15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 95, 127, 95, 95, 127, 127, 127, 95, 127, 95, 95, 95,
127, 127, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 127,
127, 127, 127, 127, 127, 127, 127, 95, 95, 95, 95, 95, 95, 95, 95,
127, 127, 95, 95, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 94, 94, 94, 94, 94, 3, 3, 132,
133, 134, 135, 135, 136, 137, 138, 139, 23, 24, 0, 0, 0, 0, 0, 140,
140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140,
140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140,
140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140,
0, 0, 140, 140, 140, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0,
95, 95, 95, 3, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
127, 95, 95, 95, 95, 95, 95, 95, 15, 15, 15, 15, 95, 15, 15, 15, 15,
15, 15, 95, 15, 15, 127, 95, 95, 15, 0, 0, 0, 0, 0, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 94, 141, 21,
21, 21, 142, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 143, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 94, 94,
94, 94, 94, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 144, 21, 21, 145,
21, 146, 146, 146, 146, 146, 146, 146, 146, 147, 147, 147, 147, 147,
147, 147, 147, 146, 146, 146, 146, 146, 146, 0, 0, 147, 147, 147, 147,
147, 147, 0, 0, 146, 146, 146, 146, 146, 146, 146, 146, 147, 147, 147,
147, 147, 147, 147, 147, 146, 146, 146, 146, 146, 146, 146, 146, 147,
147, 147, 147, 147, 147, 147, 147, 146, 146, 146, 146, 146, 146, 0,
0, 147, 147, 147, 147, 147, 147, 0, 0, 21, 146, 21, 146, 21, 146, 21,
146, 0, 147, 0, 147, 0, 147, 0, 147, 146, 146, 146, 146, 146, 146,
146, 146, 147, 147, 147, 147, 147, 147, 147, 147, 148, 148, 149, 149,
149, 149, 150, 150, 151, 151, 152, 152, 153, 153, 0, 0, 146, 146, 146,
146, 146, 146, 146, 146, 154, 154, 154, 154, 154, 154, 154, 154, 146,
146, 146, 146, 146, 146, 146, 146, 154, 154, 154, 154, 154, 154, 154,
154, 146, 146, 146, 146, 146, 146, 146, 146, 154, 154, 154, 154, 154,
154, 154, 154, 146, 146, 21, 155, 21, 0, 21, 21, 147, 147, 156, 156,
157, 11, 158, 11, 11, 11, 21, 155, 21, 0, 21, 21, 159, 159, 159, 159,
157, 11, 11, 11, 146, 146, 21, 21, 0, 0, 21, 21, 147, 147, 160, 160,
0, 11, 11, 11, 146, 146, 21, 21, 21, 116, 21, 21, 147, 147, 161, 161,
120, 11, 11, 11, 0, 0, 21, 155, 21, 0, 21, 21, 162, 162, 163, 163,
157, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17,
8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3,
3, 3, 3, 164, 165, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3,
16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17,
17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 94, 0, 0, 18,
18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 94, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 7, 7, 7, 5, 6, 0, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 122, 122, 122, 122, 95, 122, 122, 122, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 110, 14, 14, 14, 14, 110, 14, 14, 21, 110, 110, 110,
21, 21, 110, 110, 110, 21, 14, 110, 14, 14, 7, 110, 110, 110, 110,
110, 14, 14, 14, 14, 14, 14, 110, 14, 166, 14, 110, 14, 167, 168, 110,
110, 14, 21, 110, 110, 169, 110, 21, 15, 15, 15, 15, 21, 14, 14, 21,
21, 110, 110, 7, 7, 7, 7, 7, 110, 21, 21, 21, 21, 14, 7, 14, 14, 170,
14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171,
171, 171, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172,
172, 172, 172, 172, 131, 131, 131, 23, 24, 131, 131, 131, 131, 18,
14, 14, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14,
14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7,
14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14,
14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14,
14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 173, 173, 173, 173, 173, 173,
173, 173, 173, 173, 173, 173, 173, 173, 173, 173, 173, 173, 173, 173,
173, 173, 173, 173, 173, 173, 174, 174, 174, 174, 174, 174, 174, 174,
174, 174, 174, 174, 174, 174, 174, 174, 174, 174, 174, 174, 174, 174,
174, 174, 174, 174, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7,
14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7,
7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
7, 7, 7, 7, 7, 7, 7, 5, 6, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | < < | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | < | > > > > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | < | > | | | | | | | | | | | > > > > > > | | > | | < > | | | | < > | | | | | | | | | | | | | | | | > | | < > > > | | | | | | | | | | < > | | | | | | | | | > | < | | | | > | | > | | | | < > | | | | | | | | < > > | | | | | | | > < | | | | < > | | | | | | | | | > > | | > | | | | > | > | | > | > | | | | | | | | | | > | | | | | | | | | | < > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | < | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | < | < | | < | | | | 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 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 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 |
7, 7, 7, 7, 7, 7, 7, 5, 6, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 23, 24, 175, 176, 177, 178, 179, 23, 24, 23,
24, 23, 24, 180, 181, 182, 183, 21, 23, 24, 21, 23, 24, 21, 21, 21,
21, 21, 94, 94, 184, 184, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14,
23, 24, 23, 24, 95, 95, 95, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18,
3, 3, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185,
185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185,
185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 185, 0, 185, 0, 0,
0, 0, 0, 185, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0,
94, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15,
15, 15, 15, 15, 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, 3, 16, 20,
3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, 16, 20, 5,
6, 5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 94, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 8, 8, 3, 3, 3, 3, 8, 3, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
14, 14, 3, 3, 3, 5, 6, 5, 6, 5, 6, 5, 6, 8, 0, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 2, 3, 3, 3, 14, 94,
15, 131, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 14, 14, 5, 6, 5, 6, 5, 6, 5,
6, 8, 5, 6, 6, 14, 131, 131, 131, 131, 131, 131, 131, 131, 131, 95,
95, 95, 95, 127, 127, 8, 94, 94, 94, 94, 94, 14, 14, 131, 131, 131,
94, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 95, 95, 11, 11, 94,
94, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 94, 94, 94, 15,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 14, 14, 18, 18, 18, 18,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 0, 0, 0, 0, 0, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18,
18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 94, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 94, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 15, 95, 122, 122, 122, 3, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 3, 94, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 94, 94, 95, 95, 15, 15, 15, 15, 15, 15, 131, 131, 131, 131,
131, 131, 131, 131, 131, 131, 95, 95, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0,
0, 0, 0, 0, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 11, 11, 11, 11, 11, 94, 94, 94, 94, 94, 94, 94, 94,
94, 11, 11, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
21, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 94, 21,
21, 21, 21, 21, 21, 21, 21, 23, 24, 23, 24, 186, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 94, 11, 11, 23, 24, 187, 21, 15, 23, 24, 23, 24,
188, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 189, 190, 191, 192, 189, 21, 193, 194, 195, 196,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 197,
198, 199, 23, 24, 23, 24, 200, 23, 24, 0, 0, 23, 24, 0, 21, 0, 21,
23, 24, 23, 24, 23, 24, 201, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 94, 94, 94, 23, 24, 15, 94, 94, 21, 15, 15,
15, 15, 15, 15, 15, 95, 15, 15, 15, 95, 15, 15, 15, 15, 95, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 127, 127, 95, 95, 127, 14, 14, 14, 14, 95, 0, 0, 0,
18, 18, 18, 18, 18, 18, 14, 14, 4, 14, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 127, 127, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127, 127, 127, 127,
127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 95, 95, 0, 0, 0,
0, 0, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 15, 15, 15, 15, 15, 15, 3, 3, 3, 15, 3, 15, 15, 95, 15, 15, 15,
15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 3, 3, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 127, 127, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 95, 127, 127, 95, 95, 95, 95, 127, 127, 95,
95, 127, 127, 127, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 94, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 95,
94, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95,
95, 95, 95, 95, 127, 127, 95, 95, 127, 127, 95, 95, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 95, 15, 15, 15, 15, 15, 15, 15, 15, 95, 127,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 15, 15, 15, 15,
15, 15, 14, 14, 14, 15, 127, 95, 127, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 15, 95, 95, 95, 15, 15,
95, 95, 15, 15, 15, 15, 15, 95, 95, 15, 95, 15, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 94, 3, 3,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 95, 95, 127, 127,
3, 3, 15, 94, 94, 127, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 202, 21, 21, 21, 21, 21, 21, 21, 11, 94,
94, 94, 94, 21, 21, 21, 21, 21, 21, 21, 21, 21, 94, 11, 11, 0, 0, 0,
0, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 15, 15, 15, 127, 127, 95, 127, 127,
95, 127, 127, 3, 127, 95, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 204, 204, 204, 204, 204, 204, 204,
204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204,
204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 205, 205, 205,
205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205,
205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205,
205, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21,
21, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 0,
0, 0, 0, 0, 15, 95, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 0, 15, 0, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 6, 5, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 14, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 4, 14, 14, 14, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 3, 3, 3, 3, 3, 3, 3, 5, 6, 3, 0, 0, 0, 0, 0, 0, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 3, 8, 8,
12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 3, 3, 5, 6,
3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6, 5, 6, 5, 6,
3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, 0, 0, 0, 0, 15, 15, 15, 15,
15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 17, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6,
3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 11,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 5, 7, 6, 7, 5, 6, 3, 5, 6, 3, 3,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 94, 94, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15,
15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15,
0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, 0, 0
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 131, 131,
131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131,
131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131,
131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131,
131, 131, 131, 131, 131, 131, 131, 131, 131, 18, 18, 18, 18, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18,
14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 95, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 95, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 18, 18,
18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 131, 15, 15, 15, 15,
15, 15, 15, 15, 131, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 95,
95, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 3, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
3, 131, 131, 131, 131, 131, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 206, 206,
206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 207, 207, 207, 207,
207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
207, 207, 207, 207, 207, 207, 207, 207, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0,
0, 0, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
206, 206, 206, 206, 206, 206, 206, 206, 206, 0, 0, 0, 0, 207, 207,
207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
207, 207, 207, 207, 207, 207, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 3, 208, 208, 208, 208, 208, 208, 208, 208, 208, 208, 208, 0,
208, 208, 208, 208, 208, 208, 208, 208, 208, 208, 208, 208, 208, 208,
208, 0, 208, 208, 208, 208, 208, 208, 208, 0, 208, 208, 0, 209, 209,
209, 209, 209, 209, 209, 209, 209, 209, 209, 0, 209, 209, 209, 209,
209, 209, 209, 209, 209, 209, 209, 209, 209, 209, 209, 0, 209, 209,
209, 209, 209, 209, 209, 0, 209, 209, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 94,
94, 94, 94, 94, 94, 0, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 0, 94, 94,
94, 94, 94, 94, 94, 94, 94, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0,
0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 18, 18, 18, 18, 18, 18, 18,
18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 14, 14, 18, 18, 18, 18, 18, 18, 18, 0,
0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 0, 0, 18,
18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18, 0, 0, 0,
3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 3, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 18, 18, 15, 15, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 15, 95, 95, 95, 0, 95, 95, 0, 0, 0,
0, 0, 95, 95, 95, 95, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 95, 95, 95, 0, 0, 0, 0, 95,
18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3,
3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 18, 18, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 14, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 0, 0, 0, 0, 18, 18, 18, 18,
18, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18,
18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18,
18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 0, 0, 0, 0, 0, 0,
0, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 95, 95, 95, 95, 0, 0, 0,
0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 94, 15, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
0, 0, 0, 95, 95, 95, 95, 95, 8, 94, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 0, 0, 0, 0,
0, 0, 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 95, 95, 8, 0, 0, 15, 15, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 95, 95, 95, 95, 18, 18, 18, 18, 18, 18, 18, 15, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 18, 18, 18, 18, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 95, 3, 3, 3, 3, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 127, 95, 127, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 3, 3, 3, 3, 3, 3, 3,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 95, 15, 15, 95,
95, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127, 95, 95, 95, 95,
127, 127, 95, 95, 3, 3, 17, 3, 3, 3, 3, 95, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 17, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 95, 95, 95, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
95, 95, 95, 95, 95, 127, 95, 95, 95, 95, 95, 95, 95, 95, 0, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 127, 127, 15, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 95, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127,
95, 95, 95, 95, 95, 95, 95, 95, 95, 127, 127, 15, 15, 15, 15, 3, 3,
3, 3, 95, 95, 95, 95, 3, 127, 95, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15,
3, 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127, 95, 95, 95, 127,
127, 95, 127, 95, 95, 3, 3, 3, 3, 3, 3, 95, 15, 15, 95, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 3, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 127, 127, 127, 95, 95, 95,
95, 95, 95, 95, 95, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0,
0, 0, 0, 0, 0, 95, 95, 127, 127, 0, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 0, 95, 95, 15, 127, 127, 95,
127, 127, 127, 127, 0, 0, 127, 127, 0, 0, 127, 127, 127, 0, 0, 15,
0, 0, 0, 0, 0, 0, 127, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 127, 127,
0, 0, 95, 95, 95, 95, 95, 95, 95, 0, 0, 0, 95, 95, 95, 95, 95, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 127, 127, 127, 95, 95, 95,
95, 95, 95, 0, 127, 0, 0, 127, 0, 127, 127, 127, 127, 0, 127, 127,
95, 127, 95, 15, 95, 15, 3, 3, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 95,
95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127, 95, 95, 95,
95, 95, 95, 95, 95, 127, 127, 95, 95, 95, 127, 95, 15, 15, 15, 15,
3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 3, 95, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 127, 127, 127, 95, 95, 95, 95, 95, 95, 127,
95, 127, 127, 127, 127, 95, 95, 127, 95, 95, 15, 15, 3, 15, 0, 0, 0,
0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127,
95, 95, 95, 95, 0, 0, 127, 127, 127, 127, 95, 95, 127, 95, 95, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 15,
15, 15, 15, 95, 95, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 127, 127, 127, 95, 95, 95, 95, 95, 95, 95, 95,
127, 127, 95, 127, 95, 95, 3, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 127, 95,
127, 127, 95, 95, 95, 95, 95, 95, 127, 95, 15, 3, 0, 0, 0, 0, 0, 0,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 95, 127, 95, 127, 127, 95, 95, 95, 95,
127, 95, 95, 95, 95, 95, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
18, 18, 3, 3, 3, 14, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127, 95, 95, 95, 95,
95, 95, 95, 95, 95, 127, 95, 95, 3, 0, 0, 0, 0, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18,
18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127, 127, 127,
127, 127, 0, 127, 127, 0, 0, 95, 95, 127, 95, 15, 127, 15, 127, 95,
3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 127, 127, 127, 95, 95, 95, 95, 0, 0, 95, 95, 127, 127, 127, 127,
95, 15, 3, 15, 127, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95, 127, 15, 95,
95, 95, 95, 3, 3, 3, 3, 3, 3, 3, 3, 95, 0, 0, 0, 0, 0, 0, 0, 0, 15,
95, 95, 95, 95, 95, 95, 127, 127, 95, 95, 95, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 127, 95, 95, 3, 3, 3, 15, 3, 3, 3, 3, 3, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 3, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127,
95, 95, 95, 95, 95, 95, 95, 0, 95, 95, 95, 95, 95, 95, 127, 95, 15,
3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 0, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 0, 127, 95, 95, 95, 95, 95, 95,
95, 127, 95, 95, 127, 95, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95,
0, 0, 0, 95, 0, 95, 95, 0, 95, 95, 95, 95, 95, 95, 95, 15, 95, 0, 0,
0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 127, 127, 127, 127, 127, 0, 95, 95, 0, 127,
127, 95, 127, 95, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 95, 95, 127, 127, 3, 3, 0, 0, 0, 0, 0, 0, 0, 95, 95, 15,
127, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 127,
95, 95, 95, 95, 95, 0, 0, 0, 127, 127, 95, 127, 95, 3, 3, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 95, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14,
14, 14, 14, 14, 4, 4, 4, 4, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131,
131, 131, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 17,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 95, 15,
15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 127, 127, 127, 95, 95, 95, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 95, 95, 95, 95, 95, 3, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 95, 95, 95, 95, 95, 95, 95, 3, 3, 3, 3, 3, 14, 14, 14, 14,
94, 94, 94, 94, 3, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 0, 18, 18, 18, 18, 18, 18, 18, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
94, 94, 94, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 94, 3, 3, 3, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 3, 3, 3, 3,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 95, 15, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127,
127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127,
127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127,
127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127,
127, 0, 0, 0, 0, 0, 0, 0, 95, 95, 95, 95, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 3, 94, 95, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 127, 127, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 94, 94, 94, 94,
0, 94, 94, 94, 94, 94, 94, 94, 0, 94, 94, 0, 15, 15, 15, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 14, 95, 95, 3, 17, 17, 17,
17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 0, 0, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 127, 127, 95, 95, 95, 14, 14, 14, 127, 127, 127, 127, 127,
127, 17, 17, 17, 17, 17, 17, 17, 17, 95, 95, 95, 95, 95, 95, 95, 95,
14, 14, 95, 95, 95, 95, 95, 95, 95, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 95, 95, 95, 95, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 95, 95, 95, 14, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
0, 0, 0, 0, 0, 0, 0, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 21, 21, 21, 21, 21, 21, 21, 0, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 110, 0, 110, 110, 0, 0, 110, 0, 0, 110,
110, 0, 0, 110, 110, 110, 110, 0, 110, 110, 110, 110, 110, 110, 110,
110, 21, 21, 21, 21, 0, 21, 0, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 110, 110,
0, 110, 110, 110, 110, 0, 0, 110, 110, 110, 110, 110, 110, 110, 110,
0, 110, 110, 110, 110, 110, 110, 110, 0, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 110, 110, 0, 110, 110, 110, 110, 0, 110, 110, 110, 110, 110,
0, 110, 0, 0, 0, 110, 110, 110, 110, 110, 110, 110, 0, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 110, 110,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
21, 21, 21, 21, 21, 21, 0, 0, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21,
21, 21, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 7,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 7, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21,
21, 21, 21, 21, 21, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21,
110, 21, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 14, 14, 14, 14,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 14, 14, 14, 14, 14, 14, 14, 14, 95, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 95, 14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 95, 95, 95, 95, 0, 95, 95, 95,
95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
15, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 95, 95, 95,
95, 95, 95, 0, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95,
95, 95, 95, 95, 0, 0, 95, 95, 95, 95, 95, 95, 95, 0, 95, 95, 0, 95,
95, 95, 95, 95, 0, 0, 0, 0, 0, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
94, 94, 94, 94, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 95, 95, 95, 95, 95, 95, 95, 94, 94, 94, 94,
94, 94, 94, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 15, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 95, 95, 95, 95, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 4,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 95, 95, 95, 95, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 95, 95, 15, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18,
95, 95, 95, 95, 95, 95, 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, 210, 210, 210,
210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210,
210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210,
210, 210, 210, 211, 211, 211, 211, 211, 211, 211, 211, 211, 211, 211,
211, 211, 211, 211, 211, 211, 211, 211, 211, 211, 211, 211, 211, 211,
211, 211, 211, 211, 211, 211, 211, 211, 211, 95, 95, 95, 95, 95, 95,
95, 94, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 4, 18, 18, 18, 18, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
0, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 15, 0, 15, 0, 15, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0,
15, 0, 15, 0, 15, 0, 15, 15, 15, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15,
0, 15, 0, 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15,
15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
0, 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
11, 11, 11, 11, 11, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 0, 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15
#endif /* TCL_UTF_MAX > 3 */
};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
*
|
| ︙ | ︙ | |||
1673 1674 1675 1676 1677 1678 1679 |
* highest field so we can easily sign extend.
*/
static const int groups[] = {
0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 8257, 28, 19, 8322, 29,
5, 23, 16, 11, -190078, 24, 2, -30846, 321, 386, -50879, 59522,
-30911, 76930, -49790, 53825, 52801, 52545, 20289, 51777, 52033,
| | | | | | | | | | | | | | | | | | | > | | | | 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 |
* highest field so we can easily sign extend.
*/
static const int groups[] = {
0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 8257, 28, 19, 8322, 29,
5, 23, 16, 11, -190078, 24, 2, -30846, 321, 386, -50879, 59522,
-30911, 76930, -49790, 53825, 52801, 52545, 20289, 51777, 52033,
53057, -24702, 54081, 53569, -41598, -10895486, 54593, -33150,
54849, 55873, 55617, 56129, -14206, 609, 451, 674, 20354, -24767,
-14271, -33215, 2763585, -41663, 2762817, -2768510, -49855, 17729,
18241, -2760318, -2759550, -2760062, 53890, 52866, 52610, 51842,
52098, -10833534, -10832510, 53122, -10839678, -10823550, -10830718,
53634, 54146, -2750078, -10829950, -2751614, 54658, 54914, -2745982,
55938, -10830462, -10824062, 17794, 55682, 18306, 56194, -10818686,
-10817918, 4, 6, -21370, 29761, 9793, 9537, 16449, 16193, 9858,
9602, 8066, 16514, 16258, 2113, 16002, 14722, 1, 12162, 13954,
2178, 22146, 20610, -1662, 29826, -15295, 24706, -1727, 20545,
7, 3905, 3970, 12353, 12418, 8, 1859649, -769822, 9949249, 10,
1601154, 1600898, 1598594, 1598082, 1598338, 1596546, 1582466,
-9027966, -769983, -9044862, -976254, -9058174, 15234, -1949375,
-1918, -1983, -18814, -21886, -25470, -32638, -28542, -32126,
-1981, -2174, -18879, -2237, 1844610, -21951, -25535, -28607,
-32703, -32191, 13, 14, -1924287, -2145983, -2115007, 7233, 7298,
4170, 4234, 6749, 6813, -2750143, -976319, -2746047, 2763650,
2762882, -2759615, -2751679, -2760383, -2760127, -2768575, 1859714,
-9044927, -10823615, -12158, -10830783, -10833599, -10832575,
-10830015, -10817983, -10824127, -10818751, 237633, -12223, -10830527,
-9058239, -10839743, -10895551, 237698, 9949314, 18, 17, 10305,
10370, 10049, 10114, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0)
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
#endif
|
| ︙ | ︙ |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | /* * Include the static character classification tables and macros. */ #include "tclUniData.c" /* | | | | | > | | | | | | | | | | | | | | | > | 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 |
/*
* Include the static character classification tables and macros.
*/
#include "tclUniData.c"
/*
* The following masks are used for fast character category tests. The x_BITS
* values are shifted right by the category value to determine whether the
* given category is included in the set.
*/
enum UnicodeCharacterCategoryMasks {
ALPHA_BITS = (1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) |
(1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) |
(1 << OTHER_LETTER),
CONTROL_BITS = (1 << CONTROL) | (1 << FORMAT),
DIGIT_BITS = (1 << DECIMAL_DIGIT_NUMBER),
SPACE_BITS = (1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) |
(1 << PARAGRAPH_SEPARATOR),
WORD_BITS = ALPHA_BITS | DIGIT_BITS | (1 << CONNECTOR_PUNCTUATION),
PUNCT_BITS = (1 << CONNECTOR_PUNCTUATION) |
(1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) |
(1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) |
(1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION),
GRAPH_BITS = WORD_BITS | PUNCT_BITS |
(1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) |
(1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) |
(1 << OTHER_NUMBER) |
(1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) |
(1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL)
};
/*
* Unicode characters less than this value are represented by themselves in
* UTF-8 strings.
*/
#define UNICODE_SELF 0x80
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 | * None. * *--------------------------------------------------------------------------- */ Tcl_Size Tcl_UniCharToUtf( | | | < | | | < | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Size
Tcl_UniCharToUtf(
int ch, /* The Tcl_UniChar to be stored in the buffer.
* Can be or'ed with flag TCL_COMBINE. */
char *buf) /* Buffer in which the UTF-8 representation of
* ch is stored. Must be large enough to hold
* the UTF-8 character (at most 4 bytes). */
{
int flags = ch;
if (ch >= TCL_COMBINE) {
ch &= (TCL_COMBINE - 1);
}
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
return 2;
}
if (ch <= 0xFFFF) {
if ((flags & TCL_COMBINE) &&
((ch & 0xF800) == 0xD800)) {
if (ch & 0x0400) {
/* Low surrogate */
| | | | < | | | | | 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 |
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));
buf[1] |= (char) (0x80 | (0x0F & (ch >> 6)));
return 3;
}
/* Previous Tcl_UniChar was not a high surrogate, so just output */
} else {
/* High surrogate */
/* Add 0x10000 to the raw number encoded in the surrogate
* pair in order to get the code point. */
ch += 0x40;
/* Fill buffer with specific 3-byte (invalid) byte combination,
* so following low surrogate can recognize it and combine */
buf[2] = (char) ((ch << 4) & 0x30);
buf[1] = (char) (0x80 | (0x3F & (ch >> 2)));
buf[0] = (char) (0xF0 | (0x07 & (ch >> 8)));
return 1;
}
}
goto three;
}
if (ch <= 0x10FFFF) {
buf[3] = (char) (0x80 | (0x3F & ch));
buf[2] = (char) (0x80 | (0x3F & (ch >> 6)));
buf[1] = (char) (0x80 | (0x3F & (ch >> 12)));
buf[0] = (char) (0xF0 | (ch >> 18));
return 4;
}
} else if (ch == -1) {
if ( (0x80 == (0xC0 & buf[0]))
&& (0 == (0xCF & buf[1]))
&& (0xF0 == (0xF8 & buf[-1]))) {
ch = 0xD7C0
+ ((0x07 & buf[-1]) << 8)
+ ((0x3F & buf[0]) << 2)
+ ((0x30 & buf[1]) >> 4);
buf[1] = (char) (0x80 | (0x3F & ch));
buf[0] = (char) (0x80 | (0x3F & (ch >> 6)));
buf[-1] = (char) (0xE0 | (ch >> 12));
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 | * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( | | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
* 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;
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 |
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(
| | | | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
};
Tcl_Size
Tcl_UtfToUniChar(
const char *src, /* The UTF-8 string. */
int *chPtr) /* Filled with the Unicode character
* represented by the UTF-8 string. */
{
int byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 4;
while (p <= optPtr) {
| | | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 4;
while (p <= optPtr) {
p += TclUtfToUniChar(p, &ch);
*w++ = ch;
}
while ((p < endPtr) && Tcl_UtfCharComplete(p, endPtr-p)) {
p += TclUtfToUniChar(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
*w++ = UCHAR(*p++);
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
const char *
Tcl_UtfFindFirst(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
while (1) {
| | | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 |
const char *
Tcl_UtfFindFirst(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
while (1) {
int find, len = TclUtfToUniChar(src, &find);
if (find == ch) {
return src;
}
if (*src == '\0') {
return NULL;
}
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
Tcl_UtfFindLast(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
const char *last = NULL;
while (1) {
| | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
Tcl_UtfFindLast(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
const char *last = NULL;
while (1) {
int find, len = TclUtfToUniChar(src, &find);
if (find == ch) {
last = src;
}
if (*src == '\0') {
break;
}
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
if (index < 0) {
return -1;
}
while (index--) {
i = TclUtfToUniChar(src, &ch);
src += i;
}
| | | 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 |
if (index < 0) {
return -1;
}
while (index--) {
i = TclUtfToUniChar(src, &ch);
src += i;
}
TclUtfToUniChar(src, &i);
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
|
| ︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 |
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) {
| | | 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 |
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 += TclUtfToUniChar(src, &ch);
}
return src;
}
const char *
TclUtfAtIndex(
const char *src, /* The UTF-8 string. */
|
| ︙ | ︙ | |||
1326 1327 1328 1329 1330 1331 1332 |
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
| | | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 |
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUniChar(src, &ch);
upChar = Tcl_UniCharToUpper(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the upper case
* char to dst if its size is <= the original char.
*/
|
| ︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 |
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
| | | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 |
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUniChar(src, &ch);
lowChar = Tcl_UniCharToLower(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the lower case
* char to dst if its size is <= the original char.
*/
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
* Capitalize the first character and then lowercase the rest of the
* characters until we get to a null.
*/
src = dst = str;
if (*src) {
| | | | 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 |
* Capitalize the first character and then lowercase the rest of the
* characters until we get to a null.
*/
src = dst = str;
if (*src) {
len = TclUtfToUniChar(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
if (len < TclUtfCount(titleChar)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
len = TclUtfToUniChar(src, &ch);
lowChar = ch;
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
lowChar = Tcl_UniCharToLower(lowChar);
}
if (len < TclUtfCount(lowChar)) {
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 |
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
return ch1 - ch2;
}
}
return UCHAR(*cs) - UCHAR(*ct);
}
| < | 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
return ch1 - ch2;
}
}
return UCHAR(*cs) - UCHAR(*ct);
}
/*
*----------------------------------------------------------------------
*
* TclUtfCasecmp --
*
* Compare UTF chars of string cs to string ct case insensitively.
|
| ︙ | ︙ | |||
1754 1755 1756 1757 1758 1759 1760 |
if (ch1 != ch2) {
return ch1 - ch2;
}
}
}
return UCHAR(*cs) - UCHAR(*ct);
}
| < | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 |
if (ch1 != ch2) {
return ch1 - ch2;
}
}
}
return UCHAR(*cs) - UCHAR(*ct);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToUpper --
*
* Compute the uppercase equivalent of the given Unicode character.
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | * are for internal use only. Make sure they do not overlap with the public * values above. * * The Tcl*Scan*Element() routines make a determination which of 4 modes of * conversion is most appropriate for Tcl*Convert*Element() to perform, and * sets two bits of the flags value to indicate the mode selected. * | < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > > > > > | > | > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 |
* are for internal use only. Make sure they do not overlap with the public
* values above.
*
* The Tcl*Scan*Element() routines make a determination which of 4 modes of
* conversion is most appropriate for Tcl*Convert*Element() to perform, and
* sets two bits of the flags value to indicate the mode selected.
*
* For more details, see the comments on the Tcl*Scan*Element and
* Tcl*Convert*Element routines.
*/
enum ConvertFlags {
CONVERT_NONE = 0, /* The element needs no quoting. Its literal
* string is suitable as is. */
DONT_USE_BRACES = TCL_DONT_USE_BRACES,
/* The caller is insisting that brace quoting
* not be used when converting the list
* element. */
CONVERT_BRACE = 2, /* The conversion should be enclosing the
* literal string in braces. */
CONVERT_ESCAPE = 4, /* The conversion should be using backslashes
* to escape any characters in the string that
* require it. */
DONT_QUOTE_HASH = TCL_DONT_QUOTE_HASH,
/* The caller insists that a leading hash
* character ('#') should *not* be quoted. This
* is appropriate when the caller can guarantee
* the element is not the first element of a
* list, so [eval] cannot mis-parse the element
* as a comment.*/
CONVERT_MASK = CONVERT_BRACE | CONVERT_ESCAPE,
/* A mask value used to extract the conversion
* mode from the flags argument.
*
* Also indicates a strange conversion mode
* where all special characters are escaped
* with backslashes *except for braces*. This
* is a strange and unnecessary case, but it's
* part of the historical way in which lists
* have been formatted in Tcl. To experiment
* with removing this case, define the value of
* COMPAT to be 0. */
CONVERT_ANY = 16 /* The caller of TclScanElement() declares it
* can make no promise about what public flags
* will be passed to the matching call of
* TclConvertElement(). As such,
* TclScanElement() has to determine the worst
* case destination buffer length over all
* possibilities, and in other cases this means
* an overestimate of the required size.
*
* Used only by callers of TclScanElement().
* The flag value produced by a call to
* Tcl*Scan*Element() will never leave this
* bit set. */
};
#ifndef COMPAT
#define COMPAT 1
#endif
/*
* Prototypes for functions defined later in this file.
*/
static void ClearHash(Tcl_HashTable *tablePtr);
static void FreeProcessGlobalValue(void *clientData);
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 | * The ASCII characters which can make up the whitespace between list elements * are: * * \u0009 \t TAB * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED | | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | * The ASCII characters which can make up the whitespace between list elements * are: * * \u0009 \t TAB * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED * \u000D \r CARRIAGE RETURN * \u0020 SPACE * * NOTE: differences between this and other places where Tcl defines a role * for "whitespace". * * * Unlike command parsing, here NEWLINE is just another whitespace * character; its role as a command terminator in a script has no |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 | * characters that have special meaning during script evaluation need * special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON * must be BRACEd, QUOTEd, or escaped so that it does not terminate the | | | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | * characters that have special meaning during script evaluation need * special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON * must be BRACEd, QUOTEd, or escaped so that it does not terminate the * command prematurely. * * Any of the characters that begin substitutions in scripts, * \u0024 $ DOLLAR * \u005b [ OPEN BRACKET * \u005c \ BACKSLASH * need to be BRACEd or escaped. * * In any list where the first character of the first element is * \u0023 # HASH |
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in braces followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
| | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 |
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in braces followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
(char *)NULL);
}
return TCL_ERROR;
}
break;
/*
* Backslash: skip over everything up to the end of the backslash
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 |
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in quotes followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
| | | 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 |
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in quotes followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
(char *)NULL);
}
return TCL_ERROR;
}
break;
default:
if (TclIsSpaceProcM(*p)) {
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unmatched open brace in %s", typeStr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE",
| | | | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 |
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unmatched open brace in %s", typeStr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE",
(char *)NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unmatched open quote in %s", typeStr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE",
(char *)NULL);
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 |
}
if (i >= size) {
Tcl_Free((void *)argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
| | | 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 |
}
if (i >= size) {
Tcl_Free((void *)argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
(char *)NULL);
}
return TCL_ERROR;
}
argv[i] = p;
if (literal) {
memcpy(p, element, elSize);
p += elSize;
|
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 |
* the element #{a"b} like this:
* {#{a"b}}
* and not like this:
* \#{a\"b}
* This is inconsistent with [list x{a"b}], but we will not change that now.
* Set that preference here so that we compute a tight size requirement.
*/
| | | 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 |
* the element #{a"b} like this:
* {#{a"b}}
* and not like this:
* \#{a\"b}
* This is inconsistent with [list x{a"b}], but we will not change that now.
* Set that preference here so that we compute a tight size requirement.
*/
if ((*src == '#') && !(*flagPtr & DONT_QUOTE_HASH)) {
preferBrace = 1;
}
#endif
if ((*p == '{') || (*p == '"')) {
/*
* Must escape or protect so leading character of value is not
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 | bytesNeeded += extra; /* * Make room to escape leading #, if needed. */ | | | | | | | | | 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 |
bytesNeeded += extra;
/*
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & DONT_QUOTE_HASH)) {
bytesNeeded++;
}
*flagPtr = CONVERT_ESCAPE;
return bytesNeeded;
}
if (*flagPtr & CONVERT_ANY) {
/*
* The caller has not let us know what flags it will pass to
* TclConvertElement() so compute the max size we might need for any
* possible choice. Normally the formatting using escape sequences is
* the longer one, and a minimum "extra" value of 2 makes sure we
* don't request too small a buffer in those edge cases where that's
* not true.
*/
if (extra < 2) {
extra = 2;
}
*flagPtr &= ~CONVERT_ANY;
*flagPtr |= DONT_USE_BRACES;
}
if (forbidNone) {
/*
* We must request some form of quoting of escaping...
*/
#if COMPAT
if (preferEscape && !preferBrace) {
/*
* If we are quoting solely due to ] or internal " characters use
* the CONVERT_MASK mode where we escape all special characters
* except for braces. "extra" counted space needed to escape
* braces too, so subtract "braceCount" to get our actual needs.
*/
bytesNeeded += (extra - braceCount);
/* Make room to escape leading #, if needed. */
if ((*src == '#') && !(*flagPtr & DONT_QUOTE_HASH)) {
bytesNeeded++;
}
/*
* If the caller reports it will direct TclConvertElement() to
* use full escapes on the element, add back the bytes needed to
* escape the braces.
*/
if (*flagPtr & DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
return bytesNeeded;
}
#endif /* COMPAT */
if (*flagPtr & DONT_USE_BRACES) {
/*
* If the caller reports it will direct TclConvertElement() to
* use escapes, add the extra bytes needed to have room for them.
*/
bytesNeeded += extra;
/*
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & DONT_QUOTE_HASH)) {
bytesNeeded++;
}
} else {
/*
* Add 2 bytes for room for the enclosing braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_BRACE;
return bytesNeeded;
}
/*
* So far, no need to quote or escape anything.
*/
if ((*src == '#') && !(*flagPtr & DONT_QUOTE_HASH)) {
/*
* If we need to quote a leading #, make room to enclose in braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_NONE;
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 |
int conversion = flags & CONVERT_MASK;
char *p = dst;
/*
* Let the caller demand we use escape sequences rather than braces.
*/
| | | | 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 |
int conversion = flags & CONVERT_MASK;
char *p = dst;
/*
* Let the caller demand we use escape sequences rather than braces.
*/
if ((flags & DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) {
conversion = CONVERT_ESCAPE;
}
/*
* No matter what the caller demands, empty string must be braced!
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) {
p[0] = '{';
p[1] = '}';
return 2;
}
/*
* Escape leading hash as needed and requested.
*/
if ((*src == '#') && !(flags & DONT_QUOTE_HASH)) {
if (conversion == CONVERT_ESCAPE) {
p[0] = '\\';
p[1] = '#';
p += 2;
src++;
length -= (length > 0);
} else {
|
| ︙ | ︙ | |||
1596 1597 1598 1599 1600 1601 1602 |
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (char *)Tcl_Alloc(argc);
}
for (i = 0; i < argc; i++) {
| | | | 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 |
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (char *)Tcl_Alloc(argc);
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]);
}
bytesNeeded += argc;
/*
* Pass two: copy into the result area.
*/
result = (char *)Tcl_Alloc(bytesNeeded);
dst = result;
for (i = 0; i < argc; i++) {
flagPtr[i] |= ( i ? DONT_QUOTE_HASH : 0 );
dst += TclConvertElement(argv[i], TCL_INDEX_NONE, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
dst[-1] = 0;
if (flagPtr != localFlags) {
|
| ︙ | ︙ | |||
1668 1669 1670 1671 1672 1673 1674 |
do {
const char *q = trim;
Tcl_Size pInc = 0, bytesLeft = numTrim;
pp = Tcl_UtfPrev(p, bytes);
do {
pp += pInc;
| | | | 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 |
do {
const char *q = trim;
Tcl_Size pInc = 0, bytesLeft = numTrim;
pp = Tcl_UtfPrev(p, bytes);
do {
pp += pInc;
pInc = TclUtfToUniChar(pp, &ch1);
} while (pp + pInc < p);
/*
* Inner loop: scan trim string for match to current character.
*/
do {
pInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
}
q += pInc;
bytesLeft -= pInc;
|
| ︙ | ︙ | |||
1741 1742 1743 1744 1745 1746 1747 |
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
| | | | 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 |
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
Tcl_Size pInc = TclUtfToUniChar(p, &ch1);
const char *q = trim;
Tcl_Size bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
Tcl_Size qInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
|
| ︙ | ︙ | |||
1817 1818 1819 1820 1821 1822 1823 |
numBytes -= trimLeft;
/* If we did not trim the whole string, it starts with a character
* that we will not trim. Skip over it. */
if (numBytes > 0) {
int ch;
const char *first = bytes + trimLeft;
| | | 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 |
numBytes -= trimLeft;
/* If we did not trim the whole string, it starts with a character
* that we will not trim. Skip over it. */
if (numBytes > 0) {
int ch;
const char *first = bytes + trimLeft;
bytes += TclUtfToUniChar(first, &ch);
numBytes -= (bytes - first);
if (numBytes > 0) {
/* When bytes is NUL-terminated, returns
* 0 <= trimRight <= numBytes */
trimRight = TclTrimRight(bytes, numBytes, trim, numTrim);
}
|
| ︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 |
/*
* First allocate the result buffer at the size required.
*/
for (i = 0; i < argc; i++) {
bytesNeeded += strlen(argv[i]);
| | | 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
/*
* First allocate the result buffer at the size required.
*/
for (i = 0; i < argc; i++) {
bytesNeeded += strlen(argv[i]);
if (bytesNeeded < 0) {
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
}
/*
* All element bytes + (argc - 1) spaces + 1 terminating NULL.
*/
|
| ︙ | ︙ | |||
1974 1975 1976 1977 1978 1979 1980 |
*/
for (i = 0; i < objc; i++) {
Tcl_Size length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr) ||
| | | | | | 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 |
*/
for (i = 0; i < objc; i++) {
Tcl_Size length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr) ||
TclObjTypeHasProc(objPtr, indexProc)) {
continue;
}
(void)TclGetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
}
if (i == objc) {
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
if (!TclListObjIsCanonical(objPtr) &&
!TclObjTypeHasProc(objPtr, indexProc)) {
continue;
}
if (resPtr) {
Tcl_Obj *elemPtr = NULL;
Tcl_ListObjIndex(NULL, objPtr, 0, &elemPtr);
if (elemPtr == NULL) {
continue;
}
if (TclGetString(elemPtr)[0] == '#' || TCL_OK
!= Tcl_ListObjAppendList(NULL, resPtr, objPtr)) {
/* Abandon ship! */
Tcl_DecrRefCount(resPtr);
Tcl_BounceRefCount(elemPtr); // could be an abstract list element
goto slow;
}
Tcl_BounceRefCount(elemPtr); // could be an an abstract list element
|
| ︙ | ︙ | |||
2024 2025 2026 2027 2028 2029 2030 |
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
*
* First try to preallocate the size required.
*/
for (i = 0; i < objc; i++) {
| | | | 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 |
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
*
* First try to preallocate the size required.
*/
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
if (bytesNeeded > (TCL_SIZE_MAX - elemLength)) {
break; /* Overflow. Do not preallocate. See comment below. */
}
bytesNeeded += elemLength;
}
/*
* Does not matter if this fails, will simply try later to build up the
* string with each Append reallocating as needed with the usual string
* append algorithm. When that fails it will report the error.
*/
TclNewObj(resPtr);
(void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
Tcl_Size triml, trimr;
element = TclGetStringFromObj(objv[i], &elemLength);
/* Trim away the leading/trailing whitespace. */
triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
CONCAT_WS_SIZE, &trimr);
element += triml;
elemLength -= triml + trimr;
|
| ︙ | ︙ | |||
2133 2134 2135 2136 2137 2138 2139 |
*/
if (p == '*') {
/*
* Skip all successive *'s in the pattern
*/
| | | | | | | | | | | 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 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
*/
if (p == '*') {
/*
* Skip all successive *'s in the pattern
*/
while (*(++pattern) == '*');
p = *pattern;
if (p == '\0') {
return 1;
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
ch2 = (int)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
TclUtfToUniChar(pattern, &ch2);
if (nocase) {
ch2 = Tcl_UniCharToLower(ch2);
}
}
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUniChar(str, &ch1);
if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
}
} else {
/*
* There's no point in trying to make this code
* shorter, as the number of bytes you want to compare
* each time is non-constant.
*/
while (*str) {
charLen = TclUtfToUniChar(str, &ch1);
if (ch2 == ch1) {
break;
}
str += charLen;
}
}
}
if (Tcl_StringCaseMatch(str, pattern, nocase)) {
return 1;
}
if (*str == '\0') {
return 0;
}
str += TclUtfToUniChar(str, &ch1);
}
}
/*
* Check for a "?" as the next pattern character. It matches any
* single character.
*/
if (p == '?') {
pattern++;
str += TclUtfToUniChar(str, &ch1);
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed by a
* list of characters that are acceptable, or by a range (two
* characters separated by "-").
*/
if (p == '[') {
int startChar = 0, endChar = 0;
pattern++;
if (UCHAR(*str) < 0x80) {
ch1 = (int)
(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
str++;
} else {
str += TclUtfToUniChar(str, &ch1);
if (nocase) {
ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
startChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUniChar(pattern, &startChar);
if (nocase) {
startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
pattern++;
if (*pattern == '\0') {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
endChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUniChar(pattern, &endChar);
if (nocase) {
endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
|
| ︙ | ︙ | |||
2298 2299 2300 2301 2302 2303 2304 | } /* * There's no special character. Just make sure that the next bytes of * each string match. */ | | | | 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 |
}
/*
* There's no special character. Just make sure that the next bytes of
* each string match.
*/
str += TclUtfToUniChar(str, &ch1);
pattern += TclUtfToUniChar(pattern, &ch2);
if (nocase) {
if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
return 0;
}
|
| ︙ | ︙ | |||
2394 2395 2396 2397 2398 2399 2400 |
if ((p != '[') && (p != '?') && (p != '\\')) {
while ((string < stringEnd) && (p != *string)) {
string++;
}
}
if (TclByteArrayMatch(string, stringEnd - string,
| | | 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 |
if ((p != '[') && (p != '?') && (p != '\\')) {
while ((string < stringEnd) && (p != *string)) {
string++;
}
}
if (TclByteArrayMatch(string, stringEnd - string,
pattern, patternEnd - pattern, 0)) {
return 1;
}
if (string == stringEnd) {
return 0;
}
string++;
}
|
| ︙ | ︙ | |||
2594 2595 2596 2597 2598 2599 2600 |
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *bytes, /* String to append. If length is
| | > | | < | 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 |
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *bytes, /* String to append. If length is
* TCL_INDEX_NONE then this must be
* null-terminated. */
Tcl_Size length) /* Number of bytes from "bytes" to append. If
* TCL_INDEX_NONE, then append all of bytes, up
* to null at end. */
{
Tcl_Size newSize;
if (length < 0) {
length = strlen(bytes);
}
if (length > (TCL_SIZE_MAX - dsPtr->length - 1)) {
Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER
"d bytes) exceeded",
TCL_SIZE_MAX);
return NULL; /* NOTREACHED */
}
newSize = length + dsPtr->length + 1;
if (newSize > dsPtr->spaceAvl) {
if (dsPtr->string == dsPtr->staticSpace) {
char *newString;
newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
|
| ︙ | ︙ | |||
2664 2665 2666 2667 2668 2669 2670 |
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
Tcl_Size length;
| | | 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 |
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
Tcl_Size length;
const char *bytes = TclGetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
char *
TclDStringAppendDString(
Tcl_DString *dsPtr,
|
| ︙ | ︙ | |||
2730 2731 2732 2733 2734 2735 2736 |
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
| | | | 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 |
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
flags |= DONT_QUOTE_HASH;
}
newSize = dsPtr->length + needSpace + TclScanElement(element, TCL_INDEX_NONE, &flags);
if (!quoteHash) {
flags |= DONT_QUOTE_HASH;
}
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again. SPECIAL NOTE: must use
* memcpy, not strcpy, to copy the string to a larger buffer, since there
|
| ︙ | ︙ | |||
3228 3229 3230 3231 3232 3233 3234 |
* Reconsider this if we ever start treating non-ASCII Unicode
* characters as meaningful list syntax, expanded Unicode spaces as
* element separators, for example.)
*
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
| | | | | | | 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 |
* Reconsider this if we ever start treating non-ASCII Unicode
* characters as meaningful list syntax, expanded Unicode spaces as
* element separators, for example.)
*
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
}
*
*/
while ((--end >= start) && (*end == '{')) {
}
if (end < start) {
return 0;
}
/*
* (c) the trailing character of the string is already a list-element
* separator, Use the same testing routine as TclFindElement to
* enforce consistency.
*/
|
| ︙ | ︙ | |||
3362 3363 3364 3365 3366 3367 3368 |
GetWideForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to the value to be parsed */
Tcl_WideInt endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
| | | | | 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 |
GetWideForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to the value to be parsed */
Tcl_WideInt endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
* NOTE: this value may be TCL_INDEX_NONE. */
Tcl_WideInt *widePtr) /* Location filled in with a wide integer
* representing an index. */
{
int numType;
void *cd;
int code = Tcl_GetNumberFromObj(NULL, objPtr, &cd, &numType);
if (code == TCL_OK) {
if (numType == TCL_NUMBER_INT) {
/* objPtr holds an integer in the signed wide range */
*widePtr = *(Tcl_WideInt *)cd;
if ((*widePtr < 0)) {
*widePtr = (endValue == -1) ? WIDE_MIN : -1;
}
return TCL_OK;
}
if (numType == TCL_NUMBER_BIG) {
/* objPtr holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
|
| ︙ | ︙ | |||
3409 3410 3411 3412 3413 3414 3415 | * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * * Callers should pass reasonable values for endValue - one in the * valid index range or TCL_INDEX_NONE (-1), for example for an empty * list. * * Results: | | | | | | | | | 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 |
* TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1).
*
* Callers should pass reasonable values for endValue - one in the
* valid index range or TCL_INDEX_NONE (-1), for example for an empty
* list.
*
* Results:
* TCL_OK
*
* The index is stored at the address given by 'indexPtr'.
*
* TCL_ERROR
*
* The value of 'objPtr' does not have one of the expected formats. If
* 'interp' is non-NULL, an error message is left in the interpreter's
* result object.
*
* Side effects:
*
* The internal representation contained within objPtr may shimmer.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIntForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
|
| ︙ | ︙ | |||
3449 3450 3451 3452 3453 3454 3455 |
if (indexPtr != NULL) {
/* Note: check against TCL_SIZE_MAX needed for 32-bit builds */
if (wide >= 0 && wide <= TCL_SIZE_MAX) {
*indexPtr = (Tcl_Size)wide; /* A valid index */
} else if (wide > TCL_SIZE_MAX) {
*indexPtr = TCL_SIZE_MAX; /* Beyond max possible index */
} else if (wide < -1-TCL_SIZE_MAX) {
| | | | | | 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 |
if (indexPtr != NULL) {
/* Note: check against TCL_SIZE_MAX needed for 32-bit builds */
if (wide >= 0 && wide <= TCL_SIZE_MAX) {
*indexPtr = (Tcl_Size)wide; /* A valid index */
} else if (wide > TCL_SIZE_MAX) {
*indexPtr = TCL_SIZE_MAX; /* Beyond max possible index */
} else if (wide < -1-TCL_SIZE_MAX) {
*indexPtr = -1-TCL_SIZE_MAX; /* Below most negative index */
} else if ((wide < 0) && (endValue >= 0)) {
*indexPtr = TCL_INDEX_NONE; /* No clue why this special case */
} else {
*indexPtr = (Tcl_Size) wide;
}
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3493 3494 3495 3496 3497 3498 3499 |
*/
static int
GetEndOffsetFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
Tcl_WideInt endValue, /* The value to be stored at "widePtr" if
| | | | | 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 |
*/
static int
GetEndOffsetFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
Tcl_WideInt endValue, /* The value to be stored at "widePtr" if
* "objPtr" holds "end". */
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
void *cd;
while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjInternalRep ir;
Tcl_Size length;
const char *bytes = TclGetStringFromObj(objPtr, &length);
if (*bytes != 'e') {
int numType;
const char *opPtr;
int t1 = 0, t2 = 0;
/* Value doesn't start with "e" */
|
| ︙ | ︙ | |||
3527 3528 3529 3530 3531 3532 3533 | */ /* * Quick scan to see if multi-value list is even possible. * This relies on TclGetString() returning a NUL-terminated string. */ if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) | < | | | | | 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 |
*/
/*
* Quick scan to see if multi-value list is even possible.
* This relies on TclGetString() returning a NUL-terminated string.
*/
if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == TclListObjLength(NULL, objPtr, &length))
&& (length > 1)) {
goto parseError;
}
/* Passed the list screen, so parse for index arithmetic expression */
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr,
TCL_PARSE_INTEGER_ONLY)) {
Tcl_WideInt w1=0, w2=0;
/* value starts with valid integer... */
if ((*opPtr == '-') || (*opPtr == '+')) {
/* ... value continues with [-+] ... */
|
| ︙ | ︙ | |||
3653 3654 3655 3656 3657 3658 3659 |
if (TclIsSpaceProc(bytes[4])) {
/* Space after + or - not permitted. */
goto parseError;
}
/* Parse the integer offset */
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
| | | 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 |
if (TclIsSpaceProc(bytes[4])) {
/* Space after + or - not permitted. */
goto parseError;
}
/* Parse the integer offset */
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
bytes + 4, length - 4, NULL, TCL_PARSE_INTEGER_ONLY)) {
/* Not a recognized integer format */
goto parseError;
}
/* Got an integer offset; pull it from where parser left it. */
Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t);
|
| ︙ | ︙ | |||
3695 3696 3697 3698 3699 3700 3701 |
}
offset = irPtr->wideValue;
if (offset == WIDE_MAX) {
/*
* Encodes end+1. This is distinguished from end+n as noted
| | | | < | | | < < < | | | | | | | | | 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 |
}
offset = irPtr->wideValue;
if (offset == WIDE_MAX) {
/*
* Encodes end+1. This is distinguished from end+n as noted
* in function header.
* NOTE: this may wrap around if the caller passes (as lset does)
* listLen-1 as endValue and listLen is 0. The -1 will be
* interpreted as FF...FF and adding 1 will result in 0 which
* is what we want. Callers like lset which pass in listLen-1 == -1
* as endValue will have to adjust accordingly.
*/
*widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1;
} else if (offset == WIDE_MIN) {
*widePtr = (endValue == -1) ? WIDE_MIN : -1;
} else if (offset < 0) {
/* end-(n-1) - Different signs, sum cannot overflow */
*widePtr = endValue + offset + 1;
} else {
/* 0:WIDE_MAX - plain old index. */
*widePtr = offset;
}
return TCL_OK;
/* Report a parse error. */
parseError:
if (interp != NULL) {
char * bytes = TclGetString(objPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be integer?[+-]integer? or"
" end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3862 3863 3864 3865 3866 3867 3868 | /* * On 64-bit systems, indices in the range INT_MAX:TCL_SIZE_MAX are * valid indices but are not in the encodable range. Thus an * error is raised. On 32-bit systems, indices in that range indicate * the position after the end and so do not raise an error. */ if ((sizeof(int) != sizeof(Tcl_Size)) && | | | 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 |
/*
* On 64-bit systems, indices in the range INT_MAX:TCL_SIZE_MAX are
* valid indices but are not in the encodable range. Thus an
* error is raised. On 32-bit systems, indices in that range indicate
* the position after the end and so do not raise an error.
*/
if ((sizeof(int) != sizeof(Tcl_Size)) &&
(wide > INT_MAX) && (wide < WIDE_MAX-1)) {
/* 2(a,b) on 64-bit systems*/
goto rangeerror;
}
if (wide > INT_MAX) {
/*
* 3(a,b) on 64-bit systems and 2(a,b), 3(a,b) on 32-bit systems
* Because of the check above, this case holds for indices
|
| ︙ | ︙ | |||
3892 3893 3894 3895 3896 3897 3898 | * On 64-bit systems, indices in the range end-LIST_MAX:end-INT_MAX * are valid indices (with max size strings/lists) but are not in * the encodable range. Thus an error is raised. On 32-bit systems, * indices in that range indicate the position before the beginning * and so do not raise an error. */ if ((sizeof(int) != sizeof(Tcl_Size)) && | | | 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 |
* On 64-bit systems, indices in the range end-LIST_MAX:end-INT_MAX
* are valid indices (with max size strings/lists) but are not in
* the encodable range. Thus an error is raised. On 32-bit systems,
* indices in that range indicate the position before the beginning
* and so do not raise an error.
*/
if ((sizeof(int) != sizeof(Tcl_Size)) &&
(wide > (ENDVALUE - LIST_MAX)) && (wide <= INT_MAX)) {
/* 1(c), 4(a,b) on 64-bit systems */
goto rangeerror;
}
if (wide > ENDVALUE) {
/*
* 2(c) (32-bit systems), 3(c)
* All end+positive or end-negative expressions
|
| ︙ | ︙ | |||
3918 3919 3920 3921 3922 3923 3924 |
}
}
*indexPtr = idx;
return TCL_OK;
rangeerror:
if (interp) {
| < < | | | 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 |
}
}
*indexPtr = idx;
return TCL_OK;
rangeerror:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("index \"%s\" out of range", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (char *)NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3972 3973 3974 3975 3976 3977 3978 | * * Side effects: * If interp is not-NULL, an error message is stored in it. * *------------------------------------------------------------------------ */ int | | | < | | < < | < | | | | | | 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 |
*
* Side effects:
* If interp is not-NULL, an error message is stored in it.
*
*------------------------------------------------------------------------
*/
int
TclCommandWordLimitError(
Tcl_Interp *interp, /* May be NULL */
Tcl_Size count) /* If <= 0, "unknown" */
{
if (interp) {
if (count > 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Number of words (%" TCL_SIZE_MODIFIER
"d) in command exceeds limit %" TCL_SIZE_MODIFIER "d.",
count, (Tcl_Size)INT_MAX));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Number of words in command exceeds limit %"
TCL_SIZE_MODIFIER "d.",
(Tcl_Size)INT_MAX));
}
}
return TCL_ERROR; /* Always */
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4122 4123 4124 4125 4126 4127 4128 |
*
*----------------------------------------------------------------------
*/
void
TclSetProcessGlobalValue(
ProcessGlobalValue *pgvPtr,
| | < > > > > | > | | 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 |
*
*----------------------------------------------------------------------
*/
void
TclSetProcessGlobalValue(
ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue)
{
const char *bytes;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
int dummy;
Tcl_DString ds;
Tcl_MutexLock(&pgvPtr->mutex);
/*
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
Tcl_Free(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = TclGetString(newValue);
pgvPtr->numBytes = newValue->length;
Tcl_UtfToExternalDStringEx(NULL, NULL, bytes, pgvPtr->numBytes,
TCL_ENCODING_PROFILE_TCL8, &ds, NULL);
pgvPtr->numBytes = Tcl_DStringLength(&ds);
pgvPtr->value = (char *)Tcl_Alloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, Tcl_DStringValue(&ds), pgvPtr->numBytes + 1);
Tcl_DStringFree(&ds);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
}
pgvPtr->encoding = NULL;
/*
* Fill the local thread copy directly with the Tcl_Obj value to avoid
* loss of the internalrep. Increment newValue refCount early to handle case
* where we set a PGV to itself.
*/
|
| ︙ | ︙ | |||
4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 |
TclGetProcessGlobalValue(
ProcessGlobalValue *pgvPtr)
{
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
Tcl_Size epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
if (pgvPtr->encoding != current) {
/*
* The system encoding has changed since the global string value
* was saved. Convert the global value to be based on the new
* system encoding.
*/
| > | | 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 |
TclGetProcessGlobalValue(
ProcessGlobalValue *pgvPtr)
{
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
Tcl_Size epoch = pgvPtr->epoch;
Tcl_DString newValue;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
if (pgvPtr->encoding != current) {
/*
* The system encoding has changed since the global string value
* was saved. Convert the global value to be based on the new
* system encoding.
*/
Tcl_DString native;
Tcl_MutexLock(&pgvPtr->mutex);
epoch = ++pgvPtr->epoch;
Tcl_UtfToExternalDStringEx(NULL, pgvPtr->encoding, pgvPtr->value,
pgvPtr->numBytes, TCL_ENCODING_PROFILE_TCL8, &native, NULL);
Tcl_ExternalToUtfDStringEx(NULL, current, Tcl_DStringValue(&native),
Tcl_DStringLength(&native), TCL_ENCODING_PROFILE_TCL8,
|
| ︙ | ︙ | |||
4249 4250 4251 4252 4253 4254 4255 |
if (pgvPtr->value == NULL) {
Tcl_Panic("PGV Initializer did not initialize");
}
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
/*
| | > | > > > | | | 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 |
if (pgvPtr->value == NULL) {
Tcl_Panic("PGV Initializer did not initialize");
}
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
/*
* Store a copy of the shared value (but then in utf-8)
* in our epoch-indexed cache.
*/
Tcl_ExternalToUtfDString(NULL, pgvPtr->value, pgvPtr->numBytes, &newValue);
value = Tcl_DStringToObj(&newValue);
hPtr = Tcl_CreateHashEntry(cacheMap,
INT2PTR(pgvPtr->epoch), &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
Tcl_SetHashValue(hPtr, value);
Tcl_IncrRefCount(value);
}
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclSetObjNameOfExecutable --
*
* This function stores the absolute pathname of the executable file
* (normally as computed by TclpFindExecutable).
*
* Starting with Tcl 9.0, encoding parameter is not used any more.
*
* Results:
* None.
*
* Side effects:
* Stores the executable name.
*
*----------------------------------------------------------------------
*/
void
TclSetObjNameOfExecutable(
Tcl_Obj *name,
TCL_UNUSED(Tcl_Encoding))
{
TclSetProcessGlobalValue(&executableName, name);
}
/*
*----------------------------------------------------------------------
*
* TclGetObjNameOfExecutable --
*
|
| ︙ | ︙ | |||
4587 4588 4589 4590 4591 4592 4593 |
}
return TCL_OK;
invalidGlob:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
| | | 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 |
}
return TCL_OK;
invalidGlob:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, (char *)NULL);
}
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr, void *keyPtr);
static void FreeVarEntry(Tcl_HashEntry *hPtr);
static int CompareVarKeys(void *keyPtr, Tcl_HashEntry *hPtr);
static const Tcl_HashKeyType tclVarHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
| | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr, void *keyPtr);
static void FreeVarEntry(Tcl_HashEntry *hPtr);
static int CompareVarKeys(void *keyPtr, Tcl_HashEntry *hPtr);
static const Tcl_HashKeyType tclVarHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
TCL_HASH_KEY_DIRECT_COMPARE,/* allows compare keys by pointers */
TclHashObjKey, /* hashKeyProc */
CompareVarKeys, /* compareKeysProc */
AllocVarEntry, /* allocEntryProc */
FreeVarEntry /* freeEntryProc */
};
static inline Var * VarHashCreateVar(TclVarHashTable *tablePtr,
|
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); /* * TIP #508: [array default] */ | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); /* * TIP #508: [array default] */ static Tcl_ObjCmdProc ArrayDefaultCmd; static void DeleteArrayVar(Var *arrayPtr); static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); /* * Functions defined in this file that may be exported in the future for use * by the bytecode compiler and engine or to the public interface. */ |
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
static const Tcl_ObjType localVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, NULL, NULL,
TCL_OBJTYPE_V0
};
| | | | | | | | | | | | | | | 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 |
static const Tcl_ObjType localVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, NULL, NULL,
TCL_OBJTYPE_V0
};
#define LocalSetInternalRep(objPtr, index, namePtr) \
do { \
Tcl_ObjInternalRep ir; \
Tcl_Obj *ptr = (namePtr); \
if (ptr) {Tcl_IncrRefCount(ptr);} \
ir.twoPtrValue.ptr1 = ptr; \
ir.twoPtrValue.ptr2 = INT2PTR(index); \
Tcl_StoreInternalRep((objPtr), &localVarNameType, &ir); \
} while (0)
#define LocalGetInternalRep(objPtr, index, name) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL,
TCL_OBJTYPE_V0
};
#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \
do { \
Tcl_ObjInternalRep ir; \
Tcl_Obj *ptr1 = (arrayPtr); \
Tcl_Obj *ptr2 = (elem); \
if (ptr1) {Tcl_IncrRefCount(ptr1);} \
if (ptr2) {Tcl_IncrRefCount(ptr2);} \
ir.twoPtrValue.ptr1 = ptr1; \
ir.twoPtrValue.ptr2 = ptr2; \
Tcl_StoreInternalRep((objPtr), &parsedVarNameType, &ir); \
} while (0)
#define ParsedGetInternalRep(objPtr, parsed, array, elem) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &parsedVarNameType); \
(parsed) = (irPtr != NULL); \
(array) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
Var *
TclVarHashCreateVar(
TclVarHashTable *tablePtr,
const char *key,
int *newPtr)
|
| ︙ | ︙ | |||
342 343 344 345 346 347 348 |
Tcl_Interp *interp,
Tcl_Obj *name)
{
const char *nameStr = TclGetString(name);
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("\"%s\" isn't an array", nameStr));
| | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
Tcl_Interp *interp,
Tcl_Obj *name)
{
const char *nameStr = TclGetString(name);
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("\"%s\" isn't an array", nameStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclCleanupVar --
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 | /* *---------------------------------------------------------------------- * * TclLookupVar -- * * This function is used to locate a variable given its name(s). It has * been mostly superseded by TclObjLookupVar, it is now only used by the | | | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 | /* *---------------------------------------------------------------------- * * TclLookupVar -- * * This function is used to locate a variable given its name(s). It has * been mostly superseded by TclObjLookupVar, it is now only used by the * trace code. It is kept in tcl9.0 mainly because it is in the internal * stubs table, so that some extension may be calling it. * * Results: * The return value is a pointer to the variable structure indicated by * part1 and part2, or NULL if the variable couldn't be found. If the * variable is found, *arrayPtrPtr is filled in with the address of the * variable structure for the array that contains the variable (or NULL |
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
| | | | | 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 |
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an
* array. Otherwise, this is a full variable
* name that could include a parenthesized
* array element. */
const char *part2, /* Name of element within array, or NULL. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
const char *msg, /* Verb to use in error messages, e.g. "read"
* or "set". Only needed if TCL_LEAVE_ERR_MSG
* is set in flags. */
int createPart1, /* If 1, create hash table entry for part 1 of
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
int createPart2, /* If 1, create hash table entry for part 2 of
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
* parenthesized array element. */
Tcl_Obj *part2Ptr, /* Name of element within array, or NULL. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
const char *msg, /* Verb to use in error messages, e.g. "read"
* or "set". Only needed if TCL_LEAVE_ERR_MSG
* is set in flags. */
| | | | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
* parenthesized array element. */
Tcl_Obj *part2Ptr, /* Name of element within array, or NULL. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
const char *msg, /* Verb to use in error messages, e.g. "read"
* or "set". Only needed if TCL_LEAVE_ERR_MSG
* is set in flags. */
int createPart1, /* If 1, create hash table entry for part 1 of
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
int createPart2, /* If 1, create hash table entry for part 2 of
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
* ERROR: part1Ptr is already an array element, cannot specify
* a part2.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
NOSUCHVAR, -1);
| | | | | 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 |
* ERROR: part1Ptr is already an array element, cannot specify
* a part2.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
NOSUCHVAR, -1);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", (char *)NULL);
}
return NULL;
}
part2Ptr = elem;
part1Ptr = arrayPtr;
goto restart;
}
if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
Tcl_Size len;
const char *part1 = TclGetStringFromObj(part1Ptr, &len);
if ((len > 1) && (part1[len - 1] == ')')) {
const char *part2 = strchr(part1, '(');
if (part2) {
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME",
(char *)NULL);
}
return NULL;
}
arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
part2Ptr = Tcl_NewStringObj(part2 + 1,
len - (part2 - part1) - 2);
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 |
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
| | | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(part1Ptr), (char *)NULL);
}
return NULL;
}
/*
* Cache the newly found variable if possible.
*/
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 | */ LocalSetInternalRep(part1Ptr, index, cachedNamePtr); /* Then wipe it */ TclFreeInternalRep(cachedNamePtr); /* | | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
*/
LocalSetInternalRep(part1Ptr, index, cachedNamePtr);
/* Then wipe it */
TclFreeInternalRep(cachedNamePtr);
/*
* Now go ahead and convert it to the "localVarName" type,
* since we suspect at least some use of the value as a
* varname and we want to resolve it quickly.
*/
LocalSetInternalRep(cachedNamePtr, index, NULL);
}
} else {
/*
|
| ︙ | ︙ | |||
823 824 825 826 827 828 829 |
TclLookupSimpleVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
Tcl_Obj *varNamePtr, /* This is a simple variable name that could
* represent a scalar or an array. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG
* bits matter. */
| | | | 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 |
TclLookupSimpleVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
Tcl_Obj *varNamePtr, /* This is a simple variable name that could
* represent a scalar or an array. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG
* bits matter. */
int create, /* If 1, create hash table entry for varname,
* if it doesn't already exist. If 0, return
* error if it doesn't exist. */
const char **errMsgPtr,
int *indexPtr)
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
/* Points to the procedure call frame whose
* variables are currently in use. Same as the
* current procedure's frame, if any, unless
* an "uplevel" is executing. */
TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
int isNew, result;
Tcl_Size i, varLen;
const char *varName = TclGetStringFromObj(varNamePtr, &varLen);
varPtr = NULL;
varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */
*indexPtr = -3;
if (flags & TCL_GLOBAL_ONLY) {
cxtNsPtr = iPtr->globalNsPtr;
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 |
if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
|| !HasLocalVars(varFramePtr)
|| (strstr(varName, "::") != NULL)) {
const char *tail;
int lookGlobal = (flags & TCL_GLOBAL_ONLY)
|| (cxtNsPtr == iPtr->globalNsPtr)
| | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
|| !HasLocalVars(varFramePtr)
|| (strstr(varName, "::") != NULL)) {
const char *tail;
int lookGlobal = (flags & TCL_GLOBAL_ONLY)
|| (cxtNsPtr == iPtr->globalNsPtr)
|| ((varName[0] == ':') && (varName[1] == ':'));
if (lookGlobal) {
*indexPtr = -1;
flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
} else {
flags = (flags | TCL_NAMESPACE_ONLY);
*indexPtr = -2;
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
const char *localNameStr;
Tcl_Size localLen;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
| | | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 |
const char *localNameStr;
Tcl_Size localLen;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
localNameStr = TclGetStringFromObj(objPtr, &localLen);
if ((varLen == localLen) && (varName[0] == localNameStr[0])
&& !memcmp(varName, localNameStr, varLen)) {
*indexPtr = i;
return (Var *) &varFramePtr->compiledLocals[i];
}
}
}
}
tablePtr = varFramePtr->varTablePtr;
|
| ︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 |
Var *
TclLookupArrayElement(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if
* index>= 0. */
Tcl_Obj *elNamePtr, /* Name of element within array. */
| | | | | | | | | 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 |
Var *
TclLookupArrayElement(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if
* index>= 0. */
Tcl_Obj *elNamePtr, /* Name of element within array. */
int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */
const char *msg, /* Verb to use in error messages, e.g. "read"
* or "set". Only needed if TCL_LEAVE_ERR_MSG
* is set in flags. */
int createArray, /* If 1, transform arrayName to be an array if
* it isn't one yet and the transformation is
* possible. If 0, return error if it isn't
* already an array. */
int createElem, /* If 1, create hash table entry for the
* element, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var *arrayPtr, /* Pointer to the array's Var structure. */
int index) /* If >=0, the index of the local array. */
{
int isNew;
Var *varPtr;
/*
* We're dealing with an array element. Make sure the variable is an array
* and look up the element (create the element if desired).
*/
if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
if (!createArray) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
NOSUCHVAR, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
arrayNamePtr?TclGetString(arrayNamePtr):NULL, (char *)NULL);
}
return NULL;
}
/*
* Make sure we are not resurrecting a namespace variable from a
* deleted namespace!
*/
if (TclIsVarDeadHash(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
DANGLINGVAR, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
arrayNamePtr?TclGetString(arrayNamePtr):NULL, (char *)NULL);
}
return NULL;
}
TclInitArrayVar(arrayPtr);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY,
index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
arrayNamePtr?TclGetString(arrayNamePtr):NULL, (char *)NULL);
}
return NULL;
}
if (createElem) {
varPtr = VarHashCreateVar(arrayPtr->value.tablePtr, elNamePtr,
&isNew);
if (isNew) {
if (arrayPtr->flags & VAR_SEARCH_ACTIVE) {
DeleteSearches((Interp *) interp, arrayPtr);
}
TclSetVarArrayElement(varPtr);
}
} else {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, elNamePtr);
if (varPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
NOSUCHELEMENT, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT",
TclGetString(elNamePtr), (char *)NULL);
}
}
}
return varPtr;
}
/*
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjGetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
| | | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjGetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
1332 1333 1334 1335 1336 1337 1338 |
Tcl_Var varPtr, /* The variable to be read.*/
Tcl_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. */
| | | 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 |
Tcl_Var varPtr, /* The variable to be read.*/
Tcl_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 TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
if (part1Ptr == NULL) {
Tcl_Panic("part1Ptr must not be NULL");
|
| ︙ | ︙ | |||
1371 1372 1373 1374 1375 1376 1377 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrGetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
| | | | 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrGetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Var *varPtr, /* The variable to be read.*/
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 TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
int index) /* Index into the local variable table of the
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
Interp *iPtr = (Interp *) interp;
const char *msg;
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
/*
* An error. If the variable doesn't exist anymore and no-one's using it,
* then free up the relevant structures and hash table entries.
*/
errorReturn:
| | | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
/*
* An error. If the variable doesn't exist anymore and no-one's using it,
* then free up the relevant structures and hash table entries.
*/
errorReturn:
Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", (char *)NULL);
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetObjCmd(
TCL_UNUSED(void *),
| | | 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 |
*
*----------------------------------------------------------------------
*/
int
Tcl_SetObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValueObj;
if (objc == 2) {
varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL,TCL_LEAVE_ERR_MSG);
|
| ︙ | ︙ | |||
1656 1657 1658 1659 1660 1661 1662 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
| | | | 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *newValuePtr, /* New value for variable. */
int flags) /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
|
| ︙ | ︙ | |||
1727 1728 1729 1730 1731 1732 1733 |
* variable, or NULL if the variable is a
* scalar. */
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. */
Tcl_Obj *newValuePtr, /* New value for variable. */
| | | 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 |
* variable, or NULL if the variable is a
* scalar. */
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. */
Tcl_Obj *newValuePtr, /* New value for variable. */
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
if (part1Ptr == NULL) {
Tcl_Panic("part1Ptr must not be NULL");
|
| ︙ | ︙ | |||
1896 1897 1898 1899 1900 1901 1902 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrSetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
| | | | 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 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrSetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Var *varPtr, /* Reference to the variable to set. */
Var *arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
* scalar. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. NULL if the 'index'
* parameter is >= 0 */
Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr, /* New value for variable. */
int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
int index) /* Index of local var where part1 is to be
* found. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldValuePtr;
Tcl_Obj *resultPtr = NULL;
|
| ︙ | ︙ | |||
1930 1931 1932 1933 1934 1935 1936 |
*/
if (TclIsVarDeadHash(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArrayElement(varPtr)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
DANGLINGELEMENT, index);
| | | | | | 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 |
*/
if (TclIsVarDeadHash(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArrayElement(varPtr)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
DANGLINGELEMENT, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", (char *)NULL);
} else {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
DANGLINGVAR, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", (char *)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", (char *)NULL);
}
goto earlyError;
}
/*
* It's an error to try to set an array variable itself.
*/
if (TclIsVarArray(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL);
}
goto earlyError;
}
TclVarFindHiddenArray(varPtr, arrayPtr);
/*
|
| ︙ | ︙ | |||
2053 2054 2055 2056 2057 2058 2059 |
/*
* If the variable doesn't exist anymore and no-one's using it, then free
* up the relevant structures and hash table entries.
*/
cleanup:
if (resultPtr == NULL) {
| | | 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 |
/*
* If the variable doesn't exist anymore and no-one's using it, then free
* up the relevant structures and hash table entries.
*/
cleanup:
if (resultPtr == NULL) {
Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", (char *)NULL);
}
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
}
return resultPtr;
earlyError:
|
| ︙ | ︙ | |||
2165 2166 2167 2168 2169 2170 2171 |
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *incrPtr, /* Increment value. */
/* TODO: Which of these flag values really make sense? */
| | | 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 |
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *incrPtr, /* Increment value. */
/* TODO: Which of these flag values really make sense? */
int flags) /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
|
| ︙ | ︙ | |||
2221 2222 2223 2224 2225 2226 2227 |
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *incrPtr, /* Increment value. */
/* TODO: Which of these flag values really make sense? */
| | | | 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 |
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *incrPtr, /* Increment value. */
/* TODO: Which of these flag values really make sense? */
int flags, /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* 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", (char *)NULL);
}
return NULL;
}
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
}
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 |
Tcl_Var varPtr, /* The variable to be unset. */
Tcl_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. */
| | | 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 |
Tcl_Var varPtr, /* The variable to be unset. */
Tcl_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. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
if (part1Ptr == NULL) {
|
| ︙ | ︙ | |||
2474 2475 2476 2477 2478 2479 2480 |
/*
* 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);
| | | 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
/*
* 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", (char *)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
|
| ︙ | ︙ | |||
2501 2502 2503 2504 2505 2506 2507 |
/*
* It's an error to unset an undefined variable.
*/
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
| | | | 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 |
/*
* It's an error to unset an undefined variable.
*/
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (char *)NULL);
}
}
/*
* Finally, if the variable is truly not in use then free up its Var
* structure and remove it from its hash table, if any. The ref count of
* its value object, if any, was decremented above.
|
| ︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 |
Tcl_SetHashValue(tPtr, tracePtr);
}
}
if ((dummyVar.flags & VAR_TRACED_UNSET)
|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) {
| | | | | | | | | | | | | | | 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_SetHashValue(tPtr, tracePtr);
}
}
if ((dummyVar.flags & VAR_TRACED_UNSET)
|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) {
/*
* Pass the array element name to TclObjCallVarTraces(), because
* it cannot be determined from dummyVar. Alternatively, indicate
* via flags whether the variable involved in the code that caused
* the trace to be triggered was an array element, for the correct
* formatting of error messages.
*/
if (part2Ptr) {
flags |= VAR_ARRAY_ELEMENT;
} else if (TclIsVarArrayElement(varPtr)) {
part2Ptr = VarHashGetKey(varPtr);
}
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT))
| TCL_TRACE_UNSETS,
/* leaveErrMsg */ 0, index);
/*
* The traces that we just called may have triggered a change in
* the set of traces. If so, reload the traces to manipulate.
*/
|
| ︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 |
TclNewObj(varValuePtr);
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
} else {
| | | 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 |
TclNewObj(varValuePtr);
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
} else {
result = TclListObjLength(interp, newValuePtr, &numElems);
if (result != TCL_OK) {
return result;
}
}
} else {
/*
* We have arguments to append. We used to call Tcl_SetVar2 to append
|
| ︙ | ︙ | |||
2945 2946 2947 2948 2949 2950 2951 |
TclNewObj(varValuePtr);
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
| | | 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 |
TclNewObj(varValuePtr);
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
result = TclListObjLength(interp, varValuePtr, &numElems);
if (result == TCL_OK) {
result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
(objc-2), (objv+2));
}
if (result != TCL_OK) {
if (createdNewObj) {
TclDecrRefCount(varValuePtr); /* Free unneeded obj. */
|
| ︙ | ︙ | |||
2986 2987 2988 2989 2990 2991 2992 |
/*
*----------------------------------------------------------------------
*
* ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext --
*
* These functions implement the "array for" Tcl command.
* array for {k v} a {}
| | | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 |
/*
*----------------------------------------------------------------------
*
* ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext --
*
* These functions implement the "array for" Tcl command.
* array for {k v} a {}
* The array for command iterates over the array, setting the
* specified loop variables, and executing the body each iteration.
*
* ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd().
*
* ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
* inside the structure and calls VarHashFirstEntry to start the hash
* iteration.
|
| ︙ | ︙ | |||
3098 3099 3100 3101 3102 3103 3104 |
return TCL_ERROR;
}
/*
* Parse arguments.
*/
| | | | 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 |
return TCL_ERROR;
}
/*
* Parse arguments.
*/
if (TclListObjLength(interp, objv[1], &numVars) != TCL_OK) {
return TCL_ERROR;
}
if (numVars != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", (char *)NULL);
return TCL_ERROR;
}
arrayNameObj = objv[2];
if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
3206 3207 3208 3209 3210 3211 3212 |
result = TCL_OK;
if (done != TCL_CONTINUE) {
Tcl_ResetResult(interp);
if (done == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"array changed during iteration", -1));
| | | | 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 |
result = TCL_OK;
if (done != TCL_CONTINUE) {
Tcl_ResetResult(interp);
if (done == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"array changed during iteration", -1));
Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", (char *)NULL);
varPtr->flags |= TCL_LEAVE_ERR_MSG;
result = done;
}
goto arrayfordone;
}
result = TclListObjGetElements(NULL, varListObj, &varc, &varv);
if (result != TCL_OK) {
goto arrayfordone;
}
if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
goto arrayfordone;
|
| ︙ | ︙ | |||
3757 3758 3759 3760 3761 3762 3763 |
}
/*
* Get the array values corresponding to each element name.
*/
TclNewObj(tmpResObj);
| | | 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 |
}
/*
* Get the array values corresponding to each element name.
*/
TclNewObj(tmpResObj);
result = TclListObjGetElements(interp, nameLstObj, &count, &nameObjPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
for (i=0 ; i<count ; i++) {
nameObj = *nameObjPtr++;
valueObj = Tcl_ObjGetVar2(interp, varNameObj, nameObj,
|
| ︙ | ︙ | |||
4021 4022 4023 4024 4025 4026 4027 |
if (varPtr == NULL) {
return TCL_ERROR;
}
if (arrayPtr) {
CleanupVar(varPtr, arrayPtr);
TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
| | | 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 |
if (varPtr == NULL) {
return TCL_ERROR;
}
if (arrayPtr) {
CleanupVar(varPtr, arrayPtr);
TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(arrayNameObj), (char *)NULL);
return TCL_ERROR;
}
/*
* Install the contents of the dictionary or list into the array.
*/
|
| ︙ | ︙ | |||
4082 4083 4084 4085 4086 4087 4088 | * -compatibility reasons) a list. */ Tcl_Size elemLen; Tcl_Obj **elemPtrs, *copyListObj; Tcl_Size i; | | | | | 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 |
* -compatibility reasons) a list.
*/
Tcl_Size elemLen;
Tcl_Obj **elemPtrs, *copyListObj;
Tcl_Size i;
result = TclListObjLength(interp, arrayElemObj, &elemLen);
if (result != TCL_OK) {
return result;
}
if (elemLen & 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list must have an even number of elements", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", (char *)NULL);
return TCL_ERROR;
}
if (elemLen == 0) {
goto ensureArray;
}
result = TclListObjGetElements(interp, arrayElemObj,
&elemLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
/*
* We needn't worry about traces invalidating arrayPtr: should that be
|
| ︙ | ︙ | |||
4148 4149 4150 4151 4152 4153 4154 |
if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
/*
* Either an array element, or a scalar: lose!
*/
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
NEEDARRAY, -1);
| | | 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 |
if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
/*
* Either an array element, or a scalar: lose!
*/
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL);
return TCL_ERROR;
}
}
TclInitArrayVar(varPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
4476 4477 4478 4479 4480 4481 4482 |
ObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
* error messages, too. */
CallFrame *framePtr, /* Call frame containing "other" variable.
* NULL means use global :: context. */
Tcl_Obj *otherP1Ptr,
const char *otherP2, /* Two-part name of variable in framePtr. */
| | | 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 |
ObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
* error messages, too. */
CallFrame *framePtr, /* Call frame containing "other" variable.
* NULL means use global :: context. */
Tcl_Obj *otherP1Ptr,
const char *otherP2, /* Two-part name of variable in framePtr. */
int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of "other" variable. */
Tcl_Obj *myNamePtr, /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
int index) /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1 */
|
| ︙ | ︙ | |||
4532 4533 4534 4535 4536 4537 4538 |
|| (varFramePtr == NULL)
|| !HasLocalVars(varFramePtr)
|| (strstr(TclGetString(myNamePtr), "::") != NULL))) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"bad variable name \"%s\": can't create namespace "
"variable that refers to procedure variable",
TclGetString(myNamePtr)));
| | | 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 |
|| (varFramePtr == NULL)
|| !HasLocalVars(varFramePtr)
|| (strstr(TclGetString(myNamePtr), "::") != NULL))) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"bad variable name \"%s\": can't create namespace "
"variable that refers to procedure variable",
TclGetString(myNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (char *)NULL);
return TCL_ERROR;
}
}
return TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, index);
}
|
| ︙ | ︙ | |||
4648 4649 4650 4651 4652 4653 4654 | * myName looks like an array reference. */ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( "bad variable name \"%s\": can't create a scalar " "variable that looks like an array element", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", | | | | | | | 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 |
* myName looks like an array reference.
*/
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"bad variable name \"%s\": can't create a scalar "
"variable that looks like an array element", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT",
(char *)NULL);
return TCL_ERROR;
}
}
/*
* Lookup and eventually create the new variable. Set the flag bit
* TCL_AVOID_RESOLVERS to indicate the special resolution rules for
* upvar purposes:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path.
* - Bug #631741 - do not use special namespace or interp resolvers.
*/
varPtr = TclLookupSimpleVar(interp, myNamePtr,
myFlags|TCL_AVOID_RESOLVERS, /* create */ 1, &errMsg, &index);
if (varPtr == NULL) {
TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(myNamePtr), (char *)NULL);
return TCL_ERROR;
}
}
if (varPtr == otherPtr) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj(
"can't upvar from variable to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", (char *)NULL);
return TCL_ERROR;
}
if (TclIsVarTraced(varPtr)) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"variable \"%s\" has traces: can't use for upvar", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", (char *)NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
Var *linkPtr;
/*
* The variable already existed. Make sure this variable "varPtr"
* isn't the same as "otherPtr" (avoid circular links). Also, if it's
* not an upvar then it's an error. If it is an upvar, then just
* disconnect it from the thing it currently refers to.
*/
if (!TclIsVarLink(varPtr)) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"variable \"%s\" already exists", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", (char *)NULL);
return TCL_ERROR;
}
linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
4874 4875 4876 4877 4878 4879 4880 |
}
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);
| | | | | 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 |
}
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", (char *)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", (char *)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", (char *)NULL);
return TCL_ERROR;
}
/*
* Make the variable and flag it as a constant.
*/
if (TclPtrSetVar(interp, (Tcl_Var) varPtr, NULL, objv[1], NULL,
|
| ︙ | ︙ | |||
4967 4968 4969 4970 4971 4972 4973 |
* The variable name might have a scope qualifier, but the name for
* the local "link" variable must be the simple name at the tail.
*/
for (tail=varName ; *tail!='\0' ; tail++) {
/* empty body */
}
| | | 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 |
* The variable name might have a scope qualifier, but the name for
* the local "link" variable must be the simple name at the tail.
*/
for (tail=varName ; *tail!='\0' ; tail++) {
/* empty body */
}
while ((tail > varName) && ((tail[0] != ':') || (tail[-1] != ':'))) {
tail--;
}
if ((*tail == ':') && (tail > varName)) {
tail++;
}
if (tail == varName) {
|
| ︙ | ︙ | |||
5067 5068 5069 5070 5071 5072 5073 | /* * Variable cannot be an element in an array. If arrayPtr is * non-NULL, it is, so throw up an error and return. */ TclObjVarErrMsg(interp, varNamePtr, NULL, "define", ISARRAYELEMENT, -1); | | | 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 |
/*
* Variable cannot be an element in an array. If arrayPtr is
* non-NULL, it is, so throw up an error and return.
*/
TclObjVarErrMsg(interp, varNamePtr, NULL, "define",
ISARRAYELEMENT, -1);
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (char *)NULL);
return TCL_ERROR;
}
if (varPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
5218 5219 5220 5221 5222 5223 5224 | * Synthesize an error message since TclObjGetFrame doesn't do this * for this particular case. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(levelObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", | | | 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 |
* Synthesize an error message since TclObjGetFrame doesn't do this
* for this particular case.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(levelObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
TclGetString(levelObj), (char *)NULL);
return TCL_ERROR;
}
/*
* We've now finished with parsing levels; skip to the variable names.
*/
|
| ︙ | ︙ | |||
5309 5310 5311 5312 5313 5314 5315 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"search identifier \"%s\" isn't for variable \"%s\"",
handle, TclGetString(varNamePtr)));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't find search \"%s\"", handle));
}
| | | 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"search identifier \"%s\" isn't for variable \"%s\"",
handle, TclGetString(varNamePtr)));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't find search \"%s\"", handle));
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, (char *)NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* DeleteSearches --
|
| ︙ | ︙ | |||
5333 5334 5335 5336 5337 5338 5339 |
*
*----------------------------------------------------------------------
*/
static void
DeleteSearches(
Interp *iPtr,
| | | 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 |
*
*----------------------------------------------------------------------
*/
static void
DeleteSearches(
Interp *iPtr,
Var *arrayVarPtr) /* Variable whose searches are to be
* deleted. */
{
ArraySearch *searchPtr, *nextPtr;
Tcl_HashEntry *sPtr;
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
|
| ︙ | ︙ | |||
5492 5493 5494 5495 5496 5497 5498 |
if (tablePtr == &iPtr->globalNsPtr->varTable) {
flags |= TCL_GLOBAL_ONLY;
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
| | | 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 |
if (tablePtr == &iPtr->globalNsPtr->varTable) {
flags |= TCL_GLOBAL_ONLY;
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags,
-1);
VarHashDeleteEntry(varPtr);
}
VarHashDeleteTable(tablePtr);
}
|
| ︙ | ︙ | |||
5953 5954 5955 5956 5957 5958 5959 |
}
if (simpleName != name) {
Tcl_DecrRefCount(simpleNamePtr);
}
if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown variable \"%s\"", name));
| | | 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 |
}
if (simpleName != name) {
Tcl_DecrRefCount(simpleNamePtr);
}
if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown variable \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, (char *)NULL);
}
return (Tcl_Var) varPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5994 5995 5996 5997 5998 5999 6000 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *pattern, *simplePattern;
Tcl_HashSearch search;
Var *varPtr;
Namespace *nsPtr;
| < | 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *pattern, *simplePattern;
Tcl_HashSearch search;
Var *varPtr;
Namespace *nsPtr;
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
|
| ︙ | ︙ | |||
6075 6076 6077 6078 6079 6080 6081 |
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = VarHashGetKey(varPtr);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
| < < < < < < < < < < | 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 |
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = VarHashGetKey(varPtr);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
} else {
/*
* Have to scan the tables of variables.
*/
varPtr = VarHashFirstVar(&nsPtr->varTable, &search);
|
| ︙ | ︙ | |||
6110 6111 6112 6113 6114 6115 6116 |
} else {
elemObjPtr = varNamePtr;
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
varPtr = VarHashNextVar(&search);
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 |
} else {
elemObjPtr = varNamePtr;
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
varPtr = VarHashNextVar(&search);
}
}
} else if (iPtr->varFramePtr->procPtr != NULL) {
AppendLocals(interp, listPtr, simplePatternPtr, 1, 0);
}
if (simplePatternPtr) {
|
| ︙ | ︙ | |||
6568 6569 6570 6571 6572 6573 6574 |
* Skip nameless (temporary) variables and undefined variables.
*/
if (*varNamePtr && !TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
varName = TclGetString(*varNamePtr);
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
| | | 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 |
* Skip nameless (temporary) variables and undefined variables.
*/
if (*varNamePtr && !TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
varName = TclGetString(*varNamePtr);
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
if (!justConstants || TclIsVarConstant(varPtr)) {
Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
}
if (includeLinks) {
Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added);
}
}
}
|
| ︙ | ︙ | |||
6622 6623 6624 6625 6626 6627 6628 |
varPtr != NULL;
varPtr = VarHashNextVar(&search)) {
if (!TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
objNamePtr = VarHashGetKey(varPtr);
varName = TclGetString(objNamePtr);
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
| | | 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 |
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);
}
}
}
|
| ︙ | ︙ | |||
6709 6710 6711 6712 6713 6714 6715 | } /* *---------------------------------------------------------------------- * * TclInfoConstantCmd -- * | | | 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 | } /* *---------------------------------------------------------------------- * * TclInfoConstantCmd -- * * Called to implement the "info constant" command that tests 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. * |
| ︙ | ︙ | |||
6802 6803 6804 6805 6806 6807 6808 |
VarHashRefCount(varPtr)--;
}
Tcl_DecrRefCount(objPtr);
}
static int
CompareVarKeys(
| | | 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 |
VarHashRefCount(varPtr)--;
}
Tcl_DecrRefCount(objPtr);
}
static int
CompareVarKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = hPtr->key.objPtr;
const char *p1, *p2;
size_t l1, l2;
|
| ︙ | ︙ | |||
6899 6900 6901 6902 6903 6904 6905 |
}
defaultValueObj = TclGetArrayDefault(varPtr);
if (!defaultValueObj) {
/* Array default must exist. */
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"array has no default value", -1));
| | | 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 |
}
defaultValueObj = TclGetArrayDefault(varPtr);
if (!defaultValueObj) {
/* Array default must exist. */
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"array has no default value", -1));
Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, defaultValueObj);
return TCL_OK;
case OPT_SET:
if (objc != 4) {
|
| ︙ | ︙ | |||
6929 6930 6931 6932 6933 6934 6935 | * Not a valid array name. */ CleanupVar(varPtr, arrayPtr); TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", | | | | 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 |
* Not a valid array name.
*/
CleanupVar(varPtr, arrayPtr);
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(arrayNameObj), (char *)NULL);
return TCL_ERROR;
}
if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
/*
* Not an array.
*/
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL);
return TCL_ERROR;
}
if (!TclIsVarArray(varPtr)) {
TclInitArrayVar(varPtr);
}
defaultValueObj = objv[3];
|
| ︙ | ︙ | |||
7082 7083 7084 7085 7086 7087 7088 |
*
* array default set v 1
* lappend v(a) 2; # returns a new object {1 2}
* set v(b); # returns the original default object "1"
*/
if (tablePtr->defaultObj) {
| | | | | | 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 |
*
* array default set v 1
* lappend v(a) 2; # returns a new object {1 2}
* set v(b); # returns the original default object "1"
*/
if (tablePtr->defaultObj) {
Tcl_DecrRefCount(tablePtr->defaultObj);
Tcl_DecrRefCount(tablePtr->defaultObj);
}
tablePtr->defaultObj = defaultObj;
if (tablePtr->defaultObj) {
Tcl_IncrRefCount(tablePtr->defaultObj);
Tcl_IncrRefCount(tablePtr->defaultObj);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
} \
} while (0)
#define ZIPFS_MEM_ERROR(interp) \
do { \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_NewStringObj( \
"out of memory", -1)); \
| | | > < | 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 |
} \
} while (0)
#define ZIPFS_MEM_ERROR(interp) \
do { \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_NewStringObj( \
"out of memory", -1)); \
Tcl_SetErrorCode(interp, "TCL", "MALLOC", (char *)NULL); \
} \
} while (0)
#define ZIPFS_POSIX_ERROR(interp,errstr) \
do { \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
"%s: %s", errstr, Tcl_PosixError(interp))); \
} \
} while (0)
#define ZIPFS_ERROR_CODE(interp,errcode) \
do { \
if (interp) { \
Tcl_SetErrorCode(interp, \
"TCL", "ZIPFS", errcode, (char *)NULL); \
} \
} while (0)
#include "zlib.h"
#include "crypt.h"
#include "zutil.h"
#include "crc32.h"
static const z_crc_t* crc32tab;
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 104 | * Various constants and offsets found in ZIP archive files */ #define ZIP_SIG_LEN 4 /* * Local header of ZIP archive member (at very beginning of each member). */ | > > | < < | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | > > > > > > > > > > > | | > > > > > > | | | | | | | | | | > | | | | | | | | | > > | < > | | > | 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 |
* Various constants and offsets found in ZIP archive files
*/
#define ZIP_SIG_LEN 4
/*
* Local header of ZIP archive member (at very beginning of each member).
* C can't express this structure type even close to portably (thanks for
* nothing, Clang and MSVC).
*/
enum ZipLocalEntryOffsets {
ZIP_LOCAL_SIG_OFFS = 0, /* sig field offset */
ZIP_LOCAL_VERSION_OFFS = 4, /* version field offset */
ZIP_LOCAL_FLAGS_OFFS = 6, /* flags field offset */
ZIP_LOCAL_COMPMETH_OFFS = 8, /* compMethod field offset */
ZIP_LOCAL_MTIME_OFFS = 10, /* modTime field offset */
ZIP_LOCAL_MDATE_OFFS = 12, /* modDate field offset */
ZIP_LOCAL_CRC32_OFFS = 14, /* crc32 field offset */
ZIP_LOCAL_COMPLEN_OFFS = 18, /* compLen field offset */
ZIP_LOCAL_UNCOMPLEN_OFFS = 22, /* uncompLen field offset */
ZIP_LOCAL_PATHLEN_OFFS = 26, /* pathLen field offset */
ZIP_LOCAL_EXTRALEN_OFFS = 28, /* extraLen field offset */
ZIP_LOCAL_HEADER_LEN = 30 /* header part length */
};
#if 0
/* Recent enough GCC can do this. */
#define PACKED_LITTLE_ENDIAN \
__attribute__((packed, scalar_storage_order("little-endian")))
#else
#undef PACKED_LITTLE_ENDIAN /* Really don't support this yet! */
#endif
#ifdef PACKED_LITTLE_ENDIAN
/*
* Local header of ZIP archive member (at very beginning of each member).
*/
struct PACKED_LITTLE_ENDIAN ZipLocalEntry {
uint32_t sig; // == ZIP_LOCAL_HEADER_SIG
uint16_t version;
uint16_t flags;
uint16_t compMethod;
uint16_t modTime;
uint16_t modDate;
uint32_t crc32;
uint32_t compLen;
uint32_t uncompLen;
uint16_t pathLen;
uint16_t extraLen;
};
#endif
#define ZIP_LOCAL_HEADER_SIG 0x04034b50
enum ZipLocalFlags {
ZIP_LOCAL_FLAGS_UTF8 = 0x0800
};
/*
* Central header of ZIP archive member at end of ZIP file.
* C can't express this structure type even close to portably (thanks for
* nothing, Clang and MSVC).
*/
enum ZipCentralEntryOffsets {
ZIP_CENTRAL_SIG_OFFS = 0, /* sig field offset */
ZIP_CENTRAL_VERSIONMADE_OFFS = 4, /* versionMade field offset */
ZIP_CENTRAL_VERSION_OFFS = 6, /* version field offset */
ZIP_CENTRAL_FLAGS_OFFS = 8, /* flags field offset */
ZIP_CENTRAL_COMPMETH_OFFS = 10, /* compMethod field offset */
ZIP_CENTRAL_MTIME_OFFS = 12, /* modTime field offset */
ZIP_CENTRAL_MDATE_OFFS = 14, /* modDate field offset */
ZIP_CENTRAL_CRC32_OFFS = 16, /* crc32 field offset */
ZIP_CENTRAL_COMPLEN_OFFS = 20, /* compLen field offset */
ZIP_CENTRAL_UNCOMPLEN_OFFS = 24, /* uncompLen field offset */
ZIP_CENTRAL_PATHLEN_OFFS = 28, /* pathLen field offset */
ZIP_CENTRAL_EXTRALEN_OFFS = 30, /* extraLen field offset */
ZIP_CENTRAL_FCOMMENTLEN_OFFS = 32, /* commentLen field offset */
ZIP_CENTRAL_DISKFILE_OFFS = 34, /* diskFile field offset */
ZIP_CENTRAL_IATTR_OFFS = 36, /* intAttr field offset */
ZIP_CENTRAL_EATTR_OFFS = 38, /* extAttr field offset */
ZIP_CENTRAL_LOCALHDR_OFFS = 42, /* localHeaderOffset field offset */
ZIP_CENTRAL_HEADER_LEN = 46 /* header part length */
};
#ifdef PACKED_LITTLE_ENDIAN
/*
* Central header of ZIP archive member at end of ZIP file.
*/
struct PACKED_LITTLE_ENDIAN ZipCentralEntry {
uint32_t sig; // == ZIP_CENTRAL_HEADER_SIG
uint16_t versionMade;
uint16_t version;
uint16_t flags;
uint16_t compMethod;
uint16_t modTime;
uint16_t modDate;
uint32_t crc32;
uint32_t compLen;
uint32_t uncompLen;
uint16_t pathLen;
uint16_t extraLen;
uint16_t commentLen;
uint16_t diskFile;
uint16_t intAttr;
uint32_t extAttr;
uint32_t localHeaderOffset;
};
#endif
#define ZIP_CENTRAL_HEADER_SIG 0x02014b50
/*
* Central end signature at very end of ZIP file.
* C can't express this structure type even close to portably (thanks for
* nothing, Clang and MSVC).
*/
enum ZipCentralMainOffsets {
ZIP_CENTRAL_END_SIG_OFFS = 0, /* sig field offset */
ZIP_CENTRAL_DISKNO_OFFS = 4, /* diskNum field offset */
ZIP_CENTRAL_DISKDIR_OFFS = 6, /* diskDir field offset */
ZIP_CENTRAL_ENTS_OFFS = 8, /* entriesOffset field offset */
ZIP_CENTRAL_TOTALENTS_OFFS = 10, /* totalEntries field offset */
ZIP_CENTRAL_DIRSIZE_OFFS = 12, /* dirSize field offset */
ZIP_CENTRAL_DIRSTART_OFFS = 16, /* dirStart field offset */
ZIP_CENTRAL_COMMENTLEN_OFFS = 20, /* commentLen field offset */
ZIP_CENTRAL_END_LEN = 22 /* header part length */
};
#ifdef PACKED_LITTLE_ENDIAN
/*
* Central end signature at very end of ZIP file.
*/
struct PACKED_LITTLE_ENDIAN ZipCentralMain {
uint32_t sig; // == ZIP_CENTRAL_END_SIG
uint16_t diskNum;
uint16_t diskDir;
uint16_t entriesOffset;
uint16_t totalEntries;
uint32_t dirSize;
uint32_t dirStart;
uint16_t commentLen;
}
#endif
#define ZIP_CENTRAL_END_SIG 0x06054b50
#define ZIP_MIN_VERSION 20
enum ZipCompressionMethods {
ZIP_COMPMETH_STORED = 0,
ZIP_COMPMETH_DEFLATED = 8
};
#define ZIP_PASSWORD_END_SIG 0x5a5a4b50
#define ZIP_CRYPT_HDR_LEN 12
#define ZIP_MAX_FILE_SIZE INT_MAX
#define DEFAULT_WRITE_MAX_SIZE ZIP_MAX_FILE_SIZE
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
unsigned char *data; /* Memory mapped or malloc'ed file */
size_t length; /* Length of memory mapped file */
void *ptrToFree; /* Non-NULL if malloc'ed file */
size_t numFiles; /* Number of files in archive */
size_t baseOffset; /* Archive start */
size_t passOffset; /* Password start */
size_t directoryOffset; /* Archive directory start */
| | | | | | < < < > > > > > > | 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 |
unsigned char *data; /* Memory mapped or malloc'ed file */
size_t length; /* Length of memory mapped file */
void *ptrToFree; /* Non-NULL if malloc'ed file */
size_t numFiles; /* Number of files in archive */
size_t baseOffset; /* Archive start */
size_t passOffset; /* Password start */
size_t directoryOffset; /* Archive directory start */
size_t directorySize; /* Size of archive directory */
unsigned char passBuf[264]; /* Password buffer */
size_t numOpen; /* Number of open files on archive */
struct ZipEntry *entries; /* List of files in archive */
struct ZipEntry *topEnts; /* List of top-level dirs in archive */
char *mountPoint; /* Mount point name */
Tcl_Size mountPointLen; /* Length of mount point name */
#ifdef _WIN32
HANDLE mountHandle; /* Handle used for direct file access. */
#endif /* _WIN32 */
} ZipFile;
/*
* In-core description of file contained in mounted ZIP archive.
*/
typedef struct ZipEntry {
char *name; /* The full pathname of the virtual file */
ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */
size_t offset; /* Data offset into memory mapped ZIP file */
int numBytes; /* Uncompressed size of the virtual file.
* -1 for zip64 */
int numCompressedBytes; /* Compressed size of the virtual file.
* -1 for zip64 */
int compressMethod; /* Compress method */
int isDirectory; /* 0 if file, 1 if directory, -1 if root */
int depth; /* Number of slashes in path. */
int crc32; /* CRC-32 as stored in ZIP */
int timestamp; /* Modification time */
int isEncrypted; /* True if data is encrypted */
int flags; /* See ZipEntryFlags for bit definitions. */
unsigned char *data; /* File data if written */
struct ZipEntry *next; /* Next file in the same archive */
struct ZipEntry *tnext; /* Next top-level dir in archive */
} ZipEntry;
enum ZipEntryFlags {
ZE_F_CRC_COMPARED = 1, /* If 1, the CRC has been compared. */
ZE_F_CRC_CORRECT = 2, /* Only meaningful if ZE_F_CRC_COMPARED is 1 */
ZE_F_VOLUME = 4 /* Entry corresponds to //zipfs:/ */
};
/*
* File channel for file contained in mounted ZIP archive.
*
* Regarding data buffers:
* For READ-ONLY files that are not encrypted and not compressed (zip STORE
* method), ubuf points directly to the mapped zip file data in memory. No
|
| ︙ | ︙ | |||
253 254 255 256 257 258 259 |
typedef struct ZipChannel {
ZipFile *zipFilePtr; /* The ZIP file holding this channel */
ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
Tcl_Size maxWrite; /* Maximum size for write */
Tcl_Size numBytes; /* Number of bytes of uncompressed data */
Tcl_Size cursor; /* Seek position for next read or write*/
unsigned char *ubuf; /* Pointer to the uncompressed data */
| | | | | > | > > > | 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 |
typedef struct ZipChannel {
ZipFile *zipFilePtr; /* The ZIP file holding this channel */
ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
Tcl_Size maxWrite; /* Maximum size for write */
Tcl_Size numBytes; /* Number of bytes of uncompressed data */
Tcl_Size cursor; /* Seek position for next read or write*/
unsigned char *ubuf; /* Pointer to the uncompressed data */
unsigned char *ubufToFree; /* NULL if ubuf points to memory that does not
* need freeing. Else memory to free (ubuf
* may point *inside* the block) */
Tcl_Size ubufSize; /* Size of allocated ubufToFree */
int iscompr; /* True if data is compressed */
int isDirectory; /* Set to 1 if directory, or -1 if root */
int isEncrypted; /* True if data is encrypted */
int mode; /* O_WRITE, O_APPEND, O_TRUNC etc.*/
unsigned long keys[3]; /* Key for decryption */
} ZipChannel;
static inline int
ZipChannelWritable(
ZipChannel *info)
{
return (info->mode & (O_WRONLY | O_RDWR)) != 0;
}
/*
* Global variables.
*
* Most are kept in single ZipFS struct. When build with threading support
|
| ︙ | ︙ | |||
327 328 329 330 331 332 333 | static int ListMountPoints(Tcl_Interp *interp); static int ContainsMountPoint(const char *path, int pathLen); static void CleanupMount(ZipFile *zf); static Tcl_Obj * ScriptLibrarySetup(const char *dirName); static void SerializeCentralDirectoryEntry( const unsigned char *start, const unsigned char *end, unsigned char *buf, | | > | > | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 | static int ListMountPoints(Tcl_Interp *interp); static int ContainsMountPoint(const char *path, int pathLen); static void CleanupMount(ZipFile *zf); static Tcl_Obj * ScriptLibrarySetup(const char *dirName); static void SerializeCentralDirectoryEntry( const unsigned char *start, const unsigned char *end, unsigned char *buf, ZipEntry *z, size_t nameLength, long long dataStartOffset); static void SerializeCentralDirectorySuffix( const unsigned char *start, const unsigned char *end, unsigned char *buf, int entryCount, long long dataStartOffset, long long directoryStartOffset, long long suffixStartOffset); static void SerializeLocalEntryHeader( const unsigned char *start, const unsigned char *end, unsigned char *buf, ZipEntry *z, int nameLength, int align); static int IsCryptHeaderValid(ZipEntry *z, unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]); |
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
NULL, /* getCwdProc */
NULL, /* chdirProc */
};
/*
* The channel type/driver definition used for ZIP archive members.
*/
| < | | | | | | | | | | | | < | | | | | | > > | | | 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 |
NULL, /* getCwdProc */
NULL, /* chdirProc */
};
/*
* The channel type/driver definition used for ZIP archive members.
*/
static const Tcl_ChannelType zipChannelType = {
"zip",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
ZipChannelRead,
ZipChannelWrite,
NULL, /* Deprecated. */
NULL, /* Set options proc. */
NULL, /* Get options proc. */
ZipChannelWatchChannel,
ZipChannelGetFile,
ZipChannelClose,
NULL, /* Set blocking mode for raw channel. */
NULL, /* Function to flush channel. */
NULL, /* Function to handle bubbled events. */
ZipChannelWideSeek,
NULL, /* Thread action function. */
NULL, /* Truncate function. */
};
/*
*------------------------------------------------------------------------
*
* TclIsZipfsPath --
*
* Checks if the passed path has a zipfs volume prefix.
*
* Results:
* 0 if not a zipfs path
* else the length of the zipfs volume prefix
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
int
TclIsZipfsPath(
const char *path)
{
#ifdef _WIN32
return strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) ? 0 : ZIPFS_VOLUME_LEN;
#else
int i;
for (i = 0; i < ZIPFS_VOLUME_LEN; ++i) {
if (path[i] != ZIPFS_VOLUME[i] &&
(path[i] != '\\' || ZIPFS_VOLUME[i] != '/')) {
return 0;
}
}
return ZIPFS_VOLUME_LEN;
#endif
}
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 | * Returns 1 if the header is valid else 0. * * Side effects: * None. * *------------------------------------------------------------------------ */ | > | | | < | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
* Returns 1 if the header is valid else 0.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static int
IsCryptHeaderValid(
ZipEntry *z,
unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN])
{
/*
* There are multiple possibilities. The last one or two bytes of the
* encryption header should match the last one or two bytes of the
* CRC of the file. Or the last byte of the encryption header should
* be the high order byte of the file time. Depending on the archiver
* and version, any of the might be in used. We follow libzip in checking
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 | * Side effects: * On success, keys[] are updated. On failure, an error message is * left in interp if not NULL. * *------------------------------------------------------------------------ */ static int | | > | | | | > | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 |
* Side effects:
* On success, keys[] are updated. On failure, an error message is
* left in interp if not NULL.
*
*------------------------------------------------------------------------
*/
static int
DecodeCryptHeader(
Tcl_Interp *interp,
ZipEntry *z,
unsigned long keys[3], /* Updated on success. Must have been
* initialized by caller. */
unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN])
/* From zip file content */
{
int i;
int ch;
int len = z->zipFilePtr->passBuf[0] & 0xFF;
char passBuf[260];
for (i = 0; i < len; i++) {
|
| ︙ | ︙ | |||
863 864 865 866 867 868 869 |
*-------------------------------------------------------------------------
*/
static char *
DecodeZipEntryText(
const unsigned char *inputBytes,
unsigned int inputLength,
| | | 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
*-------------------------------------------------------------------------
*/
static char *
DecodeZipEntryText(
const unsigned char *inputBytes,
unsigned int inputLength,
Tcl_DString *dstPtr) /* Must have been initialized by caller! */
{
Tcl_Encoding encoding;
const char *src;
char *dst;
int dstLen, srcLen = inputLength, flags;
Tcl_EncodingState state;
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 | * Results: * TCL_OK on success with normalized mount path in dsPtr * TCL_ERROR on fail with error message in interp if not NULL * *------------------------------------------------------------------------ */ static int | | > | | | 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 |
* Results:
* TCL_OK on success with normalized mount path in dsPtr
* TCL_ERROR on fail with error message in interp if not NULL
*
*------------------------------------------------------------------------
*/
static int
NormalizeMountPoint(
Tcl_Interp *interp,
const char *mountPath,
Tcl_DString *dsPtr) /* Must be initialized by caller! */
{
const char *joiner[2];
char *joinedPath;
Tcl_Obj *unnormalizedObj;
Tcl_Obj *normalizedObj;
const char *normalizedPath;
Tcl_Size normalizedLen;
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
Tcl_DecrRefCount(unnormalizedObj);
goto errorReturn;
}
Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
Tcl_DecrRefCount(unnormalizedObj);
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
| | | | | 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
Tcl_DecrRefCount(unnormalizedObj);
goto errorReturn;
}
Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
Tcl_DecrRefCount(unnormalizedObj);
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
normalizedPath = TclGetStringFromObj(normalizedObj, &normalizedLen);
Tcl_DStringFree(&dsJoin);
Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen);
Tcl_DecrRefCount(normalizedObj);
return TCL_OK;
invalidMountPath:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Invalid mount path \"%s\"", mountPath));
ZIPFS_ERROR_CODE(interp, "MOUNT_PATH");
}
errorReturn:
Tcl_DStringFree(&dsJoin);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 | * * Side effects: * Stores mapped path in dsPtr. * *------------------------------------------------------------------------ */ static char * | | > | | | | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 |
*
* Side effects:
* Stores mapped path in dsPtr.
*
*------------------------------------------------------------------------
*/
static char *
MapPathToZipfs(
Tcl_Interp *interp,
const char *mountPath, /* Must be fully normalized */
const char *path, /* Archive content path to map */
Tcl_DString *dsPtr) /* Must be initialized and cleared
* by caller */
{
const char *joiner[2];
char *joinedPath;
Tcl_Obj *unnormalizedObj;
Tcl_Obj *normalizedObj;
const char *normalizedPath;
Tcl_Size normalizedLen;
|
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 |
/* Should not happen but continue... */
normalizedObj = unnormalizedObj;
}
Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
Tcl_DecrRefCount(unnormalizedObj);
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
| | | 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 |
/* Should not happen but continue... */
normalizedObj = unnormalizedObj;
}
Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
Tcl_DecrRefCount(unnormalizedObj);
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
normalizedPath = TclGetStringFromObj(normalizedObj, &normalizedLen);
Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen);
Tcl_DecrRefCount(normalizedObj);
return Tcl_DStringValue(dsPtr);
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1195 1196 1197 1198 1199 1200 1201 | * * Side effects: * None. * *------------------------------------------------------------------------ */ static int | | > > | > | | | | | | | | | 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 |
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static int
ContainsMountPoint(
const char *path,
int pathLen)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
if (ZipFS.zipHash.numEntries == 0) {
return 0;
}
if (pathLen < 0) {
pathLen = strlen(path);
}
/*
* We are looking for the case where the path is //zipfs:/a/b
* and there is a mount point //zipfs:/a/b/c/.. below it
*/
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
if (zf->mountPointLen == 0) {
/*
* Enumerate the contents of the ZIP; it's mounted on the root.
* TODO - a holdover from androwish? Tcl does not allow mounting
* outside of the //zipfs:/ area.
*/
ZipEntry *z;
for (z = zf->topEnts; z; z = z->tnext) {
int lenz = (int) strlen(z->name);
if ((lenz >= pathLen) &&
(z->name[pathLen] == '/' || z->name[pathLen] == '\0') &&
(strncmp(z->name, path, pathLen) == 0)) {
return 1;
}
}
} else if ((zf->mountPointLen >= pathLen)
&& (zf->mountPoint[pathLen] == '/'
|| zf->mountPoint[pathLen] == '\0'
|| pathLen == ZIPFS_VOLUME_LEN)
&& (strncmp(zf->mountPoint, path, pathLen) == 0)) {
/* Matched standard mount */
return 1;
}
}
return 0;
}
|
| ︙ | ︙ | |||
1473 1474 1475 1476 1477 1478 1479 |
* eocdDataOffset < zf->length.
* In addition, the following consistency checks must be met
* (1) cdirZipOffset <= eocdDataOffset (to prevent under flow in computation of (2))
* (2) cdirZipOffset + cdirSize <= eocdDataOffset. Else the CD will be overlapping
* the EOCD. Note this automatically means cdirZipOffset+cdirSize < zf->length.
*/
if (!(cdirZipOffset <= (size_t)eocdDataOffset &&
| | | 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 |
* eocdDataOffset < zf->length.
* In addition, the following consistency checks must be met
* (1) cdirZipOffset <= eocdDataOffset (to prevent under flow in computation of (2))
* (2) cdirZipOffset + cdirSize <= eocdDataOffset. Else the CD will be overlapping
* the EOCD. Note this automatically means cdirZipOffset+cdirSize < zf->length.
*/
if (!(cdirZipOffset <= (size_t)eocdDataOffset &&
cdirSize <= eocdDataOffset - cdirZipOffset)) {
if (!needZip) {
/* Simply point to end od data */
zf->directoryOffset = zf->baseOffset = zf->passOffset = zf->length;
return TCL_OK;
}
ZIPFS_ERROR(interp, "archive directory truncated");
ZIPFS_ERROR_CODE(interp, "NO_DIR");
|
| ︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 | } int pathlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_PATHLEN_OFFS); int comlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_FCOMMENTLEN_OFFS); int extra = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_EXTRALEN_OFFS); size_t localhdr_off = ZipReadInt(start, end, dirEntry + ZIP_CENTRAL_LOCALHDR_OFFS); const unsigned char *localP = zf->data + zf->baseOffset + localhdr_off; if (localP > (cdirStart - ZIP_LOCAL_HEADER_LEN) || | | | 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 |
}
int pathlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_PATHLEN_OFFS);
int comlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
int extra = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_EXTRALEN_OFFS);
size_t localhdr_off = ZipReadInt(start, end, dirEntry + ZIP_CENTRAL_LOCALHDR_OFFS);
const unsigned char *localP = zf->data + zf->baseOffset + localhdr_off;
if (localP > (cdirStart - ZIP_LOCAL_HEADER_LEN) ||
ZipReadInt(start, end, localP) != ZIP_LOCAL_HEADER_SIG) {
ZIPFS_ERROR(interp, "Failed to find local header");
ZIPFS_ERROR_CODE(interp, "LCL_HDR");
goto error;
}
if (localhdr_off < minoff) {
minoff = localhdr_off;
}
|
| ︙ | ︙ | |||
1640 1641 1642 1643 1644 1645 1646 |
} else {
/*
* Not an OS file, but rather something in a Tcl VFS. Must copy into
* memory.
*/
zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
| | | | | | 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 |
} else {
/*
* Not an OS file, but rather something in a Tcl VFS. Must copy into
* memory.
*/
zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
if (zf->length == (size_t)TCL_INDEX_NONE) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
/* What's the magic about 64 * 1024 * 1024 ? */
if ((zf->length <= ZIP_CENTRAL_END_LEN) ||
(zf->length - ZIP_CENTRAL_END_LEN) >
(64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
ZIPFS_ERROR(interp, "illegal file size");
ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
goto error;
}
if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
|
| ︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 | * None. * * Side effects: * Memory associated with the mounted archive is deallocated. *------------------------------------------------------------------------ */ static void | | > | 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 |
* None.
*
* Side effects:
* Memory associated with the mounted archive is deallocated.
*------------------------------------------------------------------------
*/
static void
CleanupMount(
ZipFile *zf) /* Mount point */
{
ZipEntry *z, *znext;
Tcl_HashEntry *hPtr;
for (z = zf->entries; z; z = znext) {
znext = z->next;
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
if (hPtr) {
|
| ︙ | ︙ | |||
2340 2341 2342 2343 2344 2345 2346 |
Unlock();
zipPathObj = Tcl_NewStringObj(zipname, -1);
Tcl_IncrRefCount(zipPathObj);
normZipPathObj = Tcl_FSGetNormalizedPath(interp, zipPathObj);
if (normZipPathObj == NULL) {
| | < | | | | < | < | | | 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 |
Unlock();
zipPathObj = Tcl_NewStringObj(zipname, -1);
Tcl_IncrRefCount(zipPathObj);
normZipPathObj = Tcl_FSGetNormalizedPath(interp, zipPathObj);
if (normZipPathObj == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not normalize zip filename \"%s\"", zipname));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", (char *)NULL);
ret = TCL_ERROR;
} else {
Tcl_IncrRefCount(normZipPathObj);
const char *normPath = Tcl_GetString(normZipPathObj);
if (passwd == NULL ||
(ret = IsPasswordValid(interp, passwd,
strlen(passwd))) == TCL_OK) {
zf = AllocateZipFile(interp, strlen(mountPoint));
if (zf == NULL) {
ret = TCL_ERROR;
} else {
ret = ZipFSOpenArchive(interp, normPath, 1, zf);
if (ret != TCL_OK) {
Tcl_Free(zf);
} else {
ret = ZipFSCatalogFilesystem(
interp, zf, mountPoint, passwd, normPath);
/* Note zf is already freed on error! */
}
}
}
Tcl_DecrRefCount(normZipPathObj);
if (ret == TCL_OK && interp) {
Tcl_DStringResult(interp, &ds);
|
| ︙ | ︙ | |||
2436 2437 2438 2439 2440 2441 2442 |
/*
* Have both a mount point and data to mount there.
* What's the magic about 64 * 1024 * 1024 ?
*/
ret = TCL_ERROR;
if ((datalen <= ZIP_CENTRAL_END_LEN) ||
| | | | 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 |
/*
* Have both a mount point and data to mount there.
* What's the magic about 64 * 1024 * 1024 ?
*/
ret = TCL_ERROR;
if ((datalen <= ZIP_CENTRAL_END_LEN) ||
(datalen - ZIP_CENTRAL_END_LEN) >
(64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
ZIPFS_ERROR(interp, "illegal file size");
ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
goto done;
}
zf = AllocateZipFile(interp, strlen(mountPoint));
if (zf == NULL) {
goto done;
|
| ︙ | ︙ | |||
2459 2460 2461 2462 2463 2464 2465 | ZipFSCloseArchive(interp, zf); Tcl_Free(zf); ZIPFS_MEM_ERROR(interp); goto done; } memcpy(zf->data, data, datalen); zf->ptrToFree = zf->data; | < | < | | 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 |
ZipFSCloseArchive(interp, zf);
Tcl_Free(zf);
ZIPFS_MEM_ERROR(interp);
goto done;
}
memcpy(zf->data, data, datalen);
zf->ptrToFree = zf->data;
} else {
zf->data = (unsigned char *)data;
zf->ptrToFree = NULL;
}
ret = ZipFSFindTOC(interp, 1, zf);
if (ret != TCL_OK) {
Tcl_Free(zf);
} else {
/* Note ZipFSCatalogFilesystem will free zf on error */
ret = ZipFSCatalogFilesystem(
interp, zf, mountPoint, NULL, "Memory Buffer");
}
if (ret == TCL_OK && interp) {
Tcl_DStringResult(interp, &ds);
}
|
| ︙ | ︙ | |||
2587 2588 2589 2590 2591 2592 2593 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint = NULL, *zipFile = NULL, *password = NULL;
int result;
if (objc > 4) {
| | < | 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint = NULL, *zipFile = NULL, *password = NULL;
int result;
if (objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?zipfile? ?mountpoint? ?password?");
return TCL_ERROR;
}
/*
* A single argument is treated as the mountpoint. Two arguments
* are treated as zipfile and mountpoint.
*/
if (objc > 1) {
|
| ︙ | ︙ | |||
2617 2618 2619 2620 2621 2622 2623 | } /* *------------------------------------------------------------------------- * * ZipFSMountBufferObjCmd -- * | | | 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 | } /* *------------------------------------------------------------------------- * * ZipFSMountBufferObjCmd -- * * This procedure is invoked to process the [zipfs mountdata] command. * * Results: * A standard Tcl result. * * Side effects: * A ZIP archive file is mounted, resources are allocated. * |
| ︙ | ︙ | |||
2745 2746 2747 2748 2749 2750 2751 |
Tcl_Obj *passObj;
unsigned char *passBuf;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "password");
return TCL_ERROR;
}
| | | 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 |
Tcl_Obj *passObj;
unsigned char *passBuf;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "password");
return TCL_ERROR;
}
pw = TclGetStringFromObj(objv[1], &len);
if (len == 0) {
return TCL_OK;
}
if (IsPasswordValid(interp, pw, len) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2886 2887 2888 2889 2890 2891 2892 |
}
/*
* Convert to encoded form. Note that we use strlen() here; if someone's
* crazy enough to embed NULs in filenames, they deserve what they get!
*/
| | > | 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 |
}
/*
* Convert to encoded form. Note that we use strlen() here; if someone's
* crazy enough to embed NULs in filenames, they deserve what they get!
*/
if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, zpathTcl,
TCL_INDEX_NONE, 0, &zpathDs, NULL) != TCL_OK) {
Tcl_DStringFree(&zpathDs);
return TCL_ERROR;
}
zpathExt = Tcl_DStringValue(&zpathDs);
zpathlen = strlen(zpathExt);
if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
3017 3018 3019 3020 3021 3022 3023 |
return TCL_ERROR;
}
kvbuf[i + ZIP_CRYPT_HDR_LEN] = UCHAR(zencode(keys, crc32tab, ch, tmp));
}
Tcl_ResetResult(interp);
init_keys(passwd, keys, crc32tab);
for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) {
| | > | 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 |
return TCL_ERROR;
}
kvbuf[i + ZIP_CRYPT_HDR_LEN] = UCHAR(zencode(keys, crc32tab, ch, tmp));
}
Tcl_ResetResult(interp);
init_keys(passwd, keys, crc32tab);
for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) {
kvbuf[i] = UCHAR(zencode(keys, crc32tab,
kvbuf[i + ZIP_CRYPT_HDR_LEN], tmp));
}
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 16, tmp));
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 24, tmp));
len = Tcl_Write(out, (char *) kvbuf, ZIP_CRYPT_HDR_LEN);
memset(kvbuf, 0, sizeof(kvbuf));
if (len != ZIP_CRYPT_HDR_LEN) {
goto writeErrorWithChannelOpen;
|
| ︙ | ︙ | |||
3268 3269 3270 3271 3272 3273 3274 |
static inline const char *
ComputeNameInArchive(
Tcl_Obj *pathObj, /* The path to the origin file */
Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP
* archive */
const char *strip, /* A prefix to strip; may be NULL if no
* stripping need be done. */
| | | | 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 |
static inline const char *
ComputeNameInArchive(
Tcl_Obj *pathObj, /* The path to the origin file */
Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP
* archive */
const char *strip, /* A prefix to strip; may be NULL if no
* stripping need be done. */
Tcl_Size slen) /* The length of the prefix; must be 0 if no
* stripping need be done. */
{
const char *name;
Tcl_Size len;
if (directNameObj) {
name = TclGetString(directNameObj);
} else {
name = TclGetStringFromObj(pathObj, &len);
if (slen > 0) {
if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
/*
* Guaranteed to be a NUL at the end, which will make this
* entry be skipped.
*/
|
| ︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 3350 |
Tcl_Obj *passwordObj) /* The password for encoding things. NULL if
* there's no password protection. */
{
Tcl_Channel out;
int count, ret = TCL_ERROR;
Tcl_Size pwlen = 0, slen = 0, len, i = 0;
Tcl_Size lobjc;
long long directoryStartOffset;
| > > | | | | | | 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 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 |
Tcl_Obj *passwordObj) /* The password for encoding things. NULL if
* there's no password protection. */
{
Tcl_Channel out;
int count, ret = TCL_ERROR;
Tcl_Size pwlen = 0, slen = 0, len, i = 0;
Tcl_Size lobjc;
long long dataStartOffset; /* The overall file offset of the start of the
* data section of the file. */
long long directoryStartOffset;
/* The overall file offset of the start of the
* central directory. */
long long suffixStartOffset;/* The overall file offset of the start of the
* suffix of the central directory (i.e.,
* where this data will be written). */
Tcl_Obj **lobjv, *list = mappingList;
ZipEntry *z;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable fileHash;
char *strip = NULL, *pw = NULL, passBuf[264], buf[4096];
unsigned char *start = (unsigned char *) buf;
unsigned char *end = start + sizeof(buf);
/*
* Caller has verified that the number of arguments is correct.
*/
passBuf[0] = 0;
if (passwordObj != NULL) {
pw = TclGetStringFromObj(passwordObj, &pwlen);
if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) {
return TCL_ERROR;
}
if (pwlen == 0) {
pw = NULL;
}
}
if (dirRoot != NULL) {
list = ZipFSFind(interp, dirRoot);
if (!list) {
return TCL_ERROR;
}
}
Tcl_IncrRefCount(list);
if (TclListObjLength(interp, list, &lobjc) != TCL_OK) {
Tcl_DecrRefCount(list);
return TCL_ERROR;
}
if (mappingList && (lobjc % 2)) {
Tcl_DecrRefCount(list);
ZIPFS_ERROR(interp, "need even number of elements");
ZIPFS_ERROR_CODE(interp, "LIST_LENGTH");
return TCL_ERROR;
}
if (lobjc == 0) {
Tcl_DecrRefCount(list);
ZIPFS_ERROR(interp, "empty archive");
ZIPFS_ERROR_CODE(interp, "EMPTY");
return TCL_ERROR;
}
if (TclListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) {
Tcl_DecrRefCount(list);
return TCL_ERROR;
}
out = Tcl_FSOpenFileChannel(interp, targetFile, "wb", 0755);
if (out == NULL) {
Tcl_DecrRefCount(list);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3461 3462 3463 3464 3465 3466 3467 |
memset(&zf0, 0, sizeof(ZipFile));
}
if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
/*
* Copy everything up to the ZIP-related suffix.
*/
| | | 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 |
memset(&zf0, 0, sizeof(ZipFile));
}
if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
/*
* Copy everything up to the ZIP-related suffix.
*/
if ((size_t)Tcl_Write(out, (char *) zf->data,
zf->passOffset) != zf->passOffset) {
memset(passBuf, 0, sizeof(passBuf));
Tcl_DecrRefCount(list);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
Tcl_Close(interp, out);
if (zf == &zf0) {
|
| ︙ | ︙ | |||
3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 |
"write error: %s", Tcl_PosixError(interp)));
Tcl_Close(interp, out);
return TCL_ERROR;
}
}
memset(passBuf, 0, sizeof(passBuf));
Tcl_Flush(out);
}
/*
* Prepare the contents of the ZIP archive.
*/
Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
if (mappingList == NULL && stripPrefix != NULL) {
| > > > | | 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 |
"write error: %s", Tcl_PosixError(interp)));
Tcl_Close(interp, out);
return TCL_ERROR;
}
}
memset(passBuf, 0, sizeof(passBuf));
Tcl_Flush(out);
dataStartOffset = Tcl_Tell(out);
} else {
dataStartOffset = 0;
}
/*
* Prepare the contents of the ZIP archive.
*/
Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
if (mappingList == NULL && stripPrefix != NULL) {
strip = TclGetStringFromObj(stripPrefix, &slen);
if (!slen) {
strip = NULL;
}
}
for (i = 0; i < lobjc; i += (mappingList ? 2 : 1)) {
Tcl_Obj *pathObj = lobjv[i];
const char *name = ComputeNameInArchive(pathObj,
|
| ︙ | ︙ | |||
3559 3560 3561 3562 3563 3564 3565 |
hPtr = Tcl_FindHashEntry(&fileHash, name);
if (!hPtr) {
continue;
}
z = (ZipEntry *) Tcl_GetHashValue(hPtr);
| | > | | | 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 |
hPtr = Tcl_FindHashEntry(&fileHash, name);
if (!hPtr) {
continue;
}
z = (ZipEntry *) Tcl_GetHashValue(hPtr);
if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, z->name,
TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
ret = TCL_ERROR;
goto done;
}
name = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf,
z, len, dataStartOffset);
if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN)
!= ZIP_CENTRAL_HEADER_LEN)
|| (Tcl_Write(out, name, len) != len)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
Tcl_DStringFree(&ds);
goto done;
}
Tcl_DStringFree(&ds);
count++;
}
/*
* Finalize the central directory.
*/
Tcl_Flush(out);
suffixStartOffset = Tcl_Tell(out);
SerializeCentralDirectorySuffix(start, end, (unsigned char *) buf,
count, dataStartOffset, directoryStartOffset, suffixStartOffset);
if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
goto done;
}
Tcl_Flush(out);
ret = TCL_OK;
|
| ︙ | ︙ | |||
3722 3723 3724 3725 3726 3727 3728 |
unsigned char *buf, /* Where to serialize to */
ZipEntry *z, /* The description of what to serialize. */
int nameLength, /* The length of the name. */
int align) /* The number of alignment bytes. */
{
ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
| | > | > > | > | > > > | | 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 |
unsigned char *buf, /* Where to serialize to */
ZipEntry *z, /* The description of what to serialize. */
int nameLength, /* The length of the name. */
int align) /* The number of alignment bytes. */
{
ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
ZipWriteShort(start, end, buf + ZIP_LOCAL_FLAGS_OFFS,
z->isEncrypted + ZIP_LOCAL_FLAGS_UTF8);
ZipWriteShort(start, end, buf + ZIP_LOCAL_COMPMETH_OFFS,
z->compressMethod);
ZipWriteShort(start, end, buf + ZIP_LOCAL_MTIME_OFFS,
ToDosTime(z->timestamp));
ZipWriteShort(start, end, buf + ZIP_LOCAL_MDATE_OFFS,
ToDosDate(z->timestamp));
ZipWriteInt(start, end, buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
ZipWriteInt(start, end, buf + ZIP_LOCAL_COMPLEN_OFFS,
z->numCompressedBytes);
ZipWriteInt(start, end, buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes);
ZipWriteShort(start, end, buf + ZIP_LOCAL_PATHLEN_OFFS, nameLength);
ZipWriteShort(start, end, buf + ZIP_LOCAL_EXTRALEN_OFFS, align);
}
static void
SerializeCentralDirectoryEntry(
const unsigned char *start, /* The start of writable memory. */
const unsigned char *end, /* The end of writable memory. */
unsigned char *buf, /* Where to serialize to */
ZipEntry *z, /* The description of what to serialize. */
size_t nameLength, /* The length of the name. */
long long dataStartOffset) /* The overall file offset of the start of the
* data section of the file. */
{
ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS,
ZIP_CENTRAL_HEADER_SIG);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSIONMADE_OFFS,
ZIP_MIN_VERSION);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_FLAGS_OFFS,
z->isEncrypted + ZIP_LOCAL_FLAGS_UTF8);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMPMETH_OFFS,
z->compressMethod);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_MTIME_OFFS,
ToDosTime(z->timestamp));
ZipWriteShort(start, end, buf + ZIP_CENTRAL_MDATE_OFFS,
ToDosDate(z->timestamp));
ZipWriteInt(start, end, buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
ZipWriteInt(start, end, buf + ZIP_CENTRAL_COMPLEN_OFFS,
z->numCompressedBytes);
ZipWriteInt(start, end, buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_PATHLEN_OFFS, nameLength);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKFILE_OFFS, 0);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_IATTR_OFFS, 0);
ZipWriteInt(start, end, buf + ZIP_CENTRAL_EATTR_OFFS, 0);
ZipWriteInt(start, end, buf + ZIP_CENTRAL_LOCALHDR_OFFS,
z->offset - dataStartOffset);
}
static void
SerializeCentralDirectorySuffix(
const unsigned char *start, /* The start of writable memory. */
const unsigned char *end, /* The end of writable memory. */
unsigned char *buf, /* Where to serialize to */
int entryCount, /* The number of entries in the directory */
long long dataStartOffset,
/* The overall file offset of the start of the
* data file. */
long long directoryStartOffset,
/* The overall file offset of the start of the
* central directory. */
long long suffixStartOffset)/* The overall file offset of the start of the
* suffix of the central directory (i.e.,
* where this data will be written). */
{
ZipWriteInt(start, end, buf + ZIP_CENTRAL_END_SIG_OFFS,
ZIP_CENTRAL_END_SIG);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKNO_OFFS, 0);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKDIR_OFFS, 0);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_ENTS_OFFS, entryCount);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_TOTALENTS_OFFS, entryCount);
ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSIZE_OFFS,
suffixStartOffset - directoryStartOffset);
ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSTART_OFFS,
directoryStartOffset - dataStartOffset);
ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd --
|
| ︙ | ︙ | |||
3975 3976 3977 3978 3979 3980 3981 |
mntPoint = ZIPFS_VOLUME;
} else {
if (NormalizeMountPoint(interp, Tcl_GetString(objv[1]), &dsMount) != TCL_OK) {
return TCL_ERROR;
}
mntPoint = Tcl_DStringValue(&dsMount);
}
| | < < | | 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 |
mntPoint = ZIPFS_VOLUME;
} else {
if (NormalizeMountPoint(interp, Tcl_GetString(objv[1]), &dsMount) != TCL_OK) {
return TCL_ERROR;
}
mntPoint = Tcl_DStringValue(&dsMount);
}
(void)MapPathToZipfs(interp, mntPoint, Tcl_GetString(objv[objc - 1]),
&dsPath);
Tcl_SetObjResult(interp, Tcl_DStringToObj(&dsPath));
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4082 4083 4084 4085 4086 4087 4088 |
Tcl_ListObjAppendElement(interp, result,
Tcl_NewWideIntObj(z->numCompressedBytes));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
ret = TCL_OK;
} else {
Tcl_SetErrno(ENOENT);
if (interp) {
| | < | | | 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 |
Tcl_ListObjAppendElement(interp, result,
Tcl_NewWideIntObj(z->numCompressedBytes));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
ret = TCL_OK;
} else {
Tcl_SetErrno(ENOENT);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"path \"%s\" not found in any zipfs volume",
filename));
}
ret = TCL_ERROR;
}
Unlock();
return ret;
}
|
| ︙ | ︙ | |||
4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 |
TclNewObj(searchPathObj);
Tcl_ListObjAppendElement(NULL, searchPathObj,
Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
Tcl_DecrRefCount(subDirObj);
Tcl_IncrRefCount(searchPathObj);
Tcl_SetEncodingSearchPath(searchPathObj);
Tcl_DecrRefCount(searchPathObj);
return libDirObj;
}
Tcl_Obj *
TclZipfs_TclLibrary(void)
{
Tcl_Obj *vfsInitScript;
| > > | 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 |
TclNewObj(searchPathObj);
Tcl_ListObjAppendElement(NULL, searchPathObj,
Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
Tcl_DecrRefCount(subDirObj);
Tcl_IncrRefCount(searchPathObj);
Tcl_SetEncodingSearchPath(searchPathObj);
Tcl_DecrRefCount(searchPathObj);
/* Bug [fccb9f322f]. Reinit system encoding after setting search path */
TclpSetInitialEncodings();
return libDirObj;
}
Tcl_Obj *
TclZipfs_TclLibrary(void)
{
Tcl_Obj *vfsInitScript;
|
| ︙ | ︙ | |||
4289 4290 4291 4292 4293 4294 4295 |
if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
#elif !defined(NO_DLFCN_H)
Dl_info dlinfo;
if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
| | | 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 |
if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
#elif !defined(NO_DLFCN_H)
Dl_info dlinfo;
if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
&& (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
#else
if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
#endif /* _WIN32 */
|
| ︙ | ︙ | |||
4388 4389 4390 4391 4392 4393 4394 |
if (ZipChannelWritable(info)) {
/*
* Copy channel data back into original file in archive.
*/
ZipEntry *z = info->zipEntryPtr;
assert(info->ubufToFree && info->ubuf);
unsigned char *newdata;
| | | | | 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 |
if (ZipChannelWritable(info)) {
/*
* Copy channel data back into original file in archive.
*/
ZipEntry *z = info->zipEntryPtr;
assert(info->ubufToFree && info->ubuf);
unsigned char *newdata;
newdata = (unsigned char *) Tcl_AttemptRealloc(
info->ubufToFree,
info->numBytes ? info->numBytes : 1); /* Bug [23dd83ce7c] */
if (newdata == NULL) {
/* Could not reallocate, keep existing buffer */
newdata = info->ubufToFree;
}
info->ubufToFree = NULL; /* Now newdata! */
info->ubuf = NULL;
info->ubufSize = 0;
|
| ︙ | ︙ | |||
4565 4566 4567 4568 4569 4570 4571 |
Tcl_Size needed = info->cursor + toWrite;
/* Tack on a bit for future growth. */
if (needed < (info->maxWrite - needed/2)) {
needed += needed / 2;
} else {
needed = info->maxWrite;
}
| | | | 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 |
Tcl_Size needed = info->cursor + toWrite;
/* Tack on a bit for future growth. */
if (needed < (info->maxWrite - needed/2)) {
needed += needed / 2;
} else {
needed = info->maxWrite;
}
unsigned char *newBuf = (unsigned char *)
Tcl_AttemptRealloc(info->ubufToFree, needed);
if (newBuf == NULL) {
*errloc = ENOMEM;
return -1;
}
info->ubufToFree = newBuf;
info->ubuf = info->ubufToFree;
info->ubufSize = needed;
|
| ︙ | ︙ | |||
4742 4743 4744 4745 4746 4747 4748 |
int wr = (mode & (O_WRONLY | O_RDWR)) != 0;
/* Check for unsupported modes. */
if ((ZipFS.wrmax <= 0) && wr) {
Tcl_SetErrno(EACCES);
if (interp) {
| | | | | | | < | | | < | | | | 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 |
int wr = (mode & (O_WRONLY | O_RDWR)) != 0;
/* Check for unsupported modes. */
if ((ZipFS.wrmax <= 0) && wr) {
Tcl_SetErrno(EACCES);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"writes not permitted: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
if ((mode & (O_APPEND|O_TRUNC)) && !wr) {
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Invalid flags 0x%x. O_APPEND and "
"O_TRUNC require write access: %s",
mode, Tcl_PosixError(interp)));
}
return NULL;
}
/*
* Is the file there?
*/
WriteLock();
z = ZipFSLookup(filename);
if (!z) {
Tcl_SetErrno(wr ? ENOTSUP : ENOENT);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" not %s: %s",
filename, wr ? "created" : "found",
Tcl_PosixError(interp)));
}
goto error;
}
if (z->numBytes < 0 || z->numCompressedBytes < 0 ||
z->offset >= z->zipFilePtr->length) {
/* Normally this should only happen for zip64. */
ZIPFS_ERROR(interp, "file size error (may be zip64)");
ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
goto error;
}
/* Do we support opening the file that way? */
|
| ︙ | ︙ | |||
4811 4812 4813 4814 4815 4816 4817 |
if (wr) {
if ((mode & O_TRUNC) == 0 && !z->data && (z->numBytes > ZipFS.wrmax)) {
Tcl_SetErrno(EFBIG);
ZIPFS_POSIX_ERROR(interp, "file size exceeds max writable");
goto error;
}
flags = TCL_WRITABLE;
| | > | 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 |
if (wr) {
if ((mode & O_TRUNC) == 0 && !z->data && (z->numBytes > ZipFS.wrmax)) {
Tcl_SetErrno(EFBIG);
ZIPFS_POSIX_ERROR(interp, "file size exceeds max writable");
goto error;
}
flags = TCL_WRITABLE;
if (mode & O_RDWR) {
flags |= TCL_READABLE;
}
} else {
/* Read-only */
flags |= TCL_READABLE;
}
if (z->isEncrypted) {
if (z->numCompressedBytes < ZIP_CRYPT_HDR_LEN) {
|
| ︙ | ︙ | |||
4892 4893 4894 4895 4896 4897 4898 |
* Wrap the ZipChannel into a Tcl_Channel.
*/
snprintf(cname, sizeof(cname), "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset,
ZipFS.idCount++);
z->zipFilePtr->numOpen++;
Unlock();
| | | 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 |
* Wrap the ZipChannel into a Tcl_Channel.
*/
snprintf(cname, sizeof(cname), "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset,
ZipFS.idCount++);
z->zipFilePtr->numOpen++;
Unlock();
return Tcl_CreateChannel(&zipChannelType, cname, info, flags);
error:
Unlock();
return NULL;
}
/*
|
| ︙ | ︙ | |||
4945 4946 4947 4948 4949 4950 4951 |
info->ubuf = info->ubufToFree;
if (info->ubufToFree == NULL) {
goto memoryError;
}
if (z->isEncrypted) {
assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
| | | < | 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 |
info->ubuf = info->ubufToFree;
if (info->ubufToFree == NULL) {
goto memoryError;
}
if (z->isEncrypted) {
assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
if (DecodeCryptHeader(interp, z, info->keys,
z->zipFilePtr->data + z->offset) != TCL_OK) {
goto error_cleanup;
}
}
if (mode & O_TRUNC) {
/*
* Truncate; nothing there.
|
| ︙ | ︙ | |||
5013 5014 5015 5016 5017 5018 5019 |
stream.avail_out = info->ubufSize;
if (inflateInit2(&stream, -15) != Z_OK) {
goto corruptionError;
}
err = inflate(&stream, Z_SYNC_FLUSH);
inflateEnd(&stream);
if ((err != Z_STREAM_END) &&
| | | > | > < | | 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 |
stream.avail_out = info->ubufSize;
if (inflateInit2(&stream, -15) != Z_OK) {
goto corruptionError;
}
err = inflate(&stream, Z_SYNC_FLUSH);
inflateEnd(&stream);
if ((err != Z_STREAM_END) &&
((err != Z_OK) || (stream.avail_in != 0))) {
goto corruptionError;
}
/* Even if decompression succeeded, counts should be as expected */
if ((int) stream.total_out != z->numBytes) {
goto corruptionError;
}
info->numBytes = z->numBytes;
if (cbuf) {
Tcl_Free(cbuf);
}
} else if (z->isEncrypted) {
/*
* Need to decrypt some otherwise-simple stored data.
*/
if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN ||
(z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) {
goto corruptionError;
}
int len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN;
assert(len <= info->ubufSize);
for (i = 0; i < len; i++) {
ch = zbuf[i];
info->ubuf[i] = zdecode(info->keys, crc32tab, ch);
}
info->numBytes = len;
} else {
/*
* Simple stored data. Copy into our working buffer.
*/
assert(info->ubufSize >= z->numBytes);
memcpy(info->ubuf, zbuf, z->numBytes);
info->numBytes = z->numBytes;
}
|
| ︙ | ︙ | |||
5183 5184 5185 5186 5187 5188 5189 |
*/
if ((err != Z_STREAM_END)
&& ((err != Z_OK) || (stream.avail_in != 0))) {
goto corruptionError;
}
/* Even if decompression succeeded, counts should be as expected */
| | > | > | 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 |
*/
if ((err != Z_STREAM_END)
&& ((err != Z_OK) || (stream.avail_in != 0))) {
goto corruptionError;
}
/* Even if decompression succeeded, counts should be as expected */
if ((int) stream.total_out != z->numBytes) {
goto corruptionError;
}
if (ubuf) {
info->isEncrypted = 0;
memset(info->keys, 0, sizeof(info->keys));
Tcl_Free(ubuf);
}
} else if (info->isEncrypted) {
unsigned int j, len;
/*
* Decode encrypted but uncompressed file, since we support Tcl_Seek()
* on it, and it can be randomly accessed later.
*/
if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN ||
(z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) {
goto corruptionError;
}
len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN;
ubuf = (unsigned char *) Tcl_AttemptAlloc(len);
if (ubuf == NULL) {
goto memoryError;
}
for (j = 0; j < len; j++) {
ch = info->ubuf[j];
|
| ︙ | ︙ | |||
5535 5536 5537 5538 5539 5540 5541 |
return -1;
}
if (types) {
wanted = types->type;
if ((wanted & TCL_GLOB_TYPE_MOUNT) && (wanted != TCL_GLOB_TYPE_MOUNT)) {
if (interp) {
ZIPFS_ERROR(interp,
| | | | < | | | | 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 |
return -1;
}
if (types) {
wanted = types->type;
if ((wanted & TCL_GLOB_TYPE_MOUNT) && (wanted != TCL_GLOB_TYPE_MOUNT)) {
if (interp) {
ZIPFS_ERROR(interp,
"Internal error: TCL_GLOB_TYPE_MOUNT should not "
"be set in conjunction with other glob types.");
}
return TCL_ERROR;
}
if ((wanted & (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE |
TCL_GLOB_TYPE_MOUNT)) == 0) {
/* Not looking for files,dirs,mounts. zipfs cannot have others */
return TCL_OK;
}
wanted &=
(TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE | TCL_GLOB_TYPE_MOUNT);
} else {
wanted = TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE;
}
/*
* The prefix that gets prepended to results.
*/
prefix = TclGetStringFromObj(pathPtr, &prefixLen);
/*
* The (normalized) path we're searching.
*/
path = TclGetStringFromObj(normPathPtr, &len);
Tcl_DStringInit(&dsPref);
if (strcmp(prefix, path) == 0) {
prefixBuf = NULL;
} else {
/*
* We need to strip the normalized prefix of the filenames and replace
|
| ︙ | ︙ | |||
5605 5606 5607 5608 5609 5610 5611 |
* Can we skip the complexity of actual globbing? Without a pattern,
* yes; it's a directory existence test.
*/
if (!pattern || (pattern[0] == '\0')) {
/* TODO - can't seem to get to this code from script for tests. */
/* Follow logic of what tclUnixFile.c does */
if ((wanted == (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE)) ||
| | | | 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 |
* Can we skip the complexity of actual globbing? Without a pattern,
* yes; it's a directory existence test.
*/
if (!pattern || (pattern[0] == '\0')) {
/* TODO - can't seem to get to this code from script for tests. */
/* Follow logic of what tclUnixFile.c does */
if ((wanted == (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE)) ||
(wanted == TCL_GLOB_TYPE_DIR && z->isDirectory) ||
(wanted == TCL_GLOB_TYPE_FILE && !z->isDirectory)) {
Tcl_ListObjAppendElement(NULL, result, pathPtr);
}
goto end;
}
} else {
/* Not in the hash table but could be an intermediate dir in a mount */
if (!pattern || (pattern[0] == '\0')) {
|
| ︙ | ︙ | |||
5651 5652 5653 5654 5655 5656 5657 |
notDuplicate = 0;
Tcl_InitHashTable(&duplicates, TCL_STRING_KEYS);
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
if (foundInHash) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr;
| | | | | | | | | | > | < | | 5755 5756 5757 5758 5759 5760 5761 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 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 |
notDuplicate = 0;
Tcl_InitHashTable(&duplicates, TCL_STRING_KEYS);
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
if (foundInHash) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if ((wanted == (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE)) ||
(wanted == TCL_GLOB_TYPE_DIR && z->isDirectory) ||
(wanted == TCL_GLOB_TYPE_FILE && !z->isDirectory)) {
if ((z->depth == scnt) &&
((z->flags & ZE_F_VOLUME) == 0) /* Bug 14db54d81e */
&& Tcl_StringCaseMatch(z->name, pat, 0)) {
Tcl_CreateHashEntry(&duplicates, z->name + strip,
¬Duplicate);
assert(notDuplicate);
AppendWithPrefix(result, prefixBuf, z->name + strip, -1);
}
}
}
}
if (wanted & TCL_GLOB_TYPE_DIR) {
/*
* Also check paths that are ancestors of a mount. e.g. glob
* //zipfs:/a/? with mount at //zipfs:/a/b/c. Also have to be
* careful about duplicates, such as when another mount is
* //zipfs:/a/b/d
*/
Tcl_DString ds;
Tcl_DStringInit(&ds);
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (Tcl_StringCaseMatch(zf->mountPoint, pat, 0)) {
const char *tail = zf->mountPoint + len;
if (*tail == '\0') {
continue;
}
const char *end = strchr(tail, '/');
Tcl_DStringAppend(&ds, zf->mountPoint + strip,
end ? (Tcl_Size)(end - zf->mountPoint) : -1);
const char *matchedPath = Tcl_DStringValue(&ds);
(void)Tcl_CreateHashEntry(
&duplicates, matchedPath, ¬Duplicate);
if (notDuplicate) {
AppendWithPrefix(
result, prefixBuf, matchedPath, Tcl_DStringLength(&ds));
}
|
| ︙ | ︙ | |||
5741 5742 5743 5744 5745 5746 5747 |
* filenames, or NULL if no prefix is to be
* used. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int l;
Tcl_Size normLength;
| | | 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 |
* filenames, or NULL if no prefix is to be
* used. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int l;
Tcl_Size normLength;
const char *path = TclGetStringFromObj(normPathPtr, &normLength);
Tcl_Size len = normLength;
if (len < 1) {
/*
* Shouldn't happen. But "shouldn't"...
*/
|
| ︙ | ︙ | |||
5823 5824 5825 5826 5827 5828 5829 5830 |
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
TCL_UNUSED(void **))
{
Tcl_Size len;
char *path;
| > > > > > > > > > > > > > > > > > > | | | | > > | > > | > > > > > > | 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 |
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
TCL_UNUSED(void **))
{
Tcl_Size len;
char *path;
int ret, decrRef = 0;
if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) {
/*
* The cwd is native (or path is absolute), use the translated path
* without worrying about normalization (this will also usually be
* shorter so the utf-to-external conversion will be somewhat faster).
*/
pathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (pathPtr == NULL) {
return -1;
}
decrRef = 1; /* Tcl_FSGetTranslatedPath increases refCount */
} else {
/*
* Make sure the normalized path is set.
*/
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
/* Tcl_FSGetNormalizedPath doesn't increase refCount */
}
path = TclGetStringFromObj(pathPtr, &len);
/*
* Claim any path under ZIPFS_VOLUME as ours. This is both a necessary
* and sufficient condition as zipfs mounts at arbitrary paths are
* not permitted (unlike Androwish).
*/
ret = (
(len < ZIPFS_VOLUME_LEN) ||
strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN)
) ? -1 : TCL_OK;
if (decrRef) {
Tcl_DecrRefCount(pathPtr);
}
return ret;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSListVolumesProc --
*
|
| ︙ | ︙ | |||
5947 5948 5949 5950 5951 5952 5953 |
char *path;
ZipEntry *z;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
| | | 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 |
char *path;
ZipEntry *z;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
path = TclGetStringFromObj(pathPtr, &len);
ReadLock();
z = ZipFSLookup(path);
if (!z && !ContainsMountPoint(path, -1)) {
Tcl_SetErrno(ENOENT);
ZIPFS_POSIX_ERROR(interp, "file not found");
ret = TCL_ERROR;
goto done;
|
| ︙ | ︙ | |||
5970 5971 5972 5973 5974 5975 5976 |
break;
case ZIP_ATTR_OFFSET:
TclNewIntObj(*objPtrRef, z ? z->offset : 0);
break;
case ZIP_ATTR_MOUNT:
if (z) {
*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
| | | 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 |
break;
case ZIP_ATTR_OFFSET:
TclNewIntObj(*objPtrRef, z ? z->offset : 0);
break;
case ZIP_ATTR_MOUNT:
if (z) {
*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
z->zipFilePtr->mountPointLen);
} else {
*objPtrRef = Tcl_NewStringObj("", 0);
}
break;
case ZIP_ATTR_ARCHIVE:
*objPtrRef = Tcl_NewStringObj(z ? z->zipFilePtr->name : "", -1);
break;
|
| ︙ | ︙ | |||
6162 6163 6164 6165 6166 6167 6168 |
}
if (altPath) {
Tcl_DecrRefCount(altPath);
}
return ret;
#endif /* ANDROID */
}
| < < | 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 |
}
if (altPath) {
Tcl_DecrRefCount(altPath);
}
return ret;
#endif /* ANDROID */
}
/*
*-------------------------------------------------------------------------
*
* TclZipfs_Init --
*
* Perform per interpreter initialization of this module.
|
| ︙ | ︙ | |||
6186 6187 6188 6189 6190 6191 6192 |
*-------------------------------------------------------------------------
*/
int
TclZipfs_Init(
Tcl_Interp *interp) /* Current interpreter. */
{
| < < | | | | | | | > > | 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 |
*-------------------------------------------------------------------------
*/
int
TclZipfs_Init(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap initMap[] = {
{"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1},
{"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1},
{"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1},
{"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1},
{"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1},
{"mountdata", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1},
{"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1},
{"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1},
{"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 1},
{"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 1},
{"list", ZipFSListObjCmd, NULL, NULL, NULL, 1},
{"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 1},
{"root", ZipFSRootObjCmd, NULL, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char findproc[] =
"namespace eval ::tcl::zipfs {}\n"
"proc ::tcl::zipfs::Find dir {\n"
" set result {}\n"
" if {[catch {\n"
" concat [glob -directory $dir -nocomplain *] [glob -directory $dir -types hidden -nocomplain *]\n"
" } list]} {\n"
" return $result\n"
" }\n"
" foreach file $list {\n"
" if {[file tail $file] in {. ..}} {\n"
" continue\n"
" }\n"
" lappend result $file {*}[Find $file]\n"
|
| ︙ | ︙ | |||
6252 6253 6254 6255 6256 6257 6258 | Tcl_IsSafe(interp) ? (initMap + 4) : initMap); /* * Add the [zipfs find] subcommand. */ Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); | < | < < < < < < < < | 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 |
Tcl_IsSafe(interp) ? (initMap + 4) : initMap);
/*
* Add the [zipfs find] subcommand.
*/
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
TclDictPutString(NULL, mapObj, "find", "::tcl::zipfs::find");
Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
ZipFSTclLibraryObjCmd, NULL, NULL);
}
return TCL_OK;
}
#if !defined(STATIC_BUILD)
static int
ZipfsAppHookFindTclInit(
const char *archive)
{
Tcl_Obj *vfsInitScript;
int found;
|
| ︙ | ︙ | |||
6324 6325 6326 6327 6328 6329 6330 | * None. * * Side effects: * Frees up archives loaded into memory. * *------------------------------------------------------------------------ */ | > | | 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 |
* None.
*
* Side effects:
* Frees up archives loaded into memory.
*
*------------------------------------------------------------------------
*/
void
TclZipfsFinalize(void)
{
WriteLock();
if (!ZipFS.initialized) {
Unlock();
return;
}
|
| ︙ | ︙ | |||
6490 6491 6492 6493 6494 6495 6496 |
Tcl_DStringFree(&ds);
#endif /* _WIN32 */
#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */
}
return result;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 |
Tcl_DStringFree(&ds);
#endif /* _WIN32 */
#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */
}
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * public domain March 2003. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | < | | | | | | > | 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 |
* public domain March 2003.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "zlib.h"
#include "tclIO.h"
/*
* The version of the zlib "package" that this implements. Note that this
* thoroughly supersedes the versions included with tclkit, which are "1.1",
* so this is at least "2.0" (there's no general *commitment* to have the same
* interface, even if that is mostly true).
*/
#define TCL_ZLIB_VERSION "2.0.1"
/*
* Magic flags used with wbits fields to indicate that we're handling the gzip
* format or automatic detection of format. Putting it here is slightly less
* gross!
*/
enum WBitsFlags {
WBITS_RAW = (-MAX_WBITS), /* RAW compressed data */
WBITS_ZLIB = (MAX_WBITS), /* Zlib-format compressed data */
WBITS_GZIP = (MAX_WBITS | 16), /* Gzip-format compressed data */
WBITS_AUTODETECT = (MAX_WBITS | 32) /* Auto-detect format from its header */
};
/*
* Structure used for handling gzip headers that are generated from a
* dictionary. It comprises the header structure itself plus some working
* space that it is very convenient to have attached.
*/
|
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
typedef struct {
Tcl_Interp *interp;
z_stream stream; /* The interface to the zlib library. */
int streamEnd; /* If we've got to end-of-stream. */
Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
Tcl_Obj *currentInput; /* Pointer to what is currently being
* inflated. */
| | > | > | 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 |
typedef struct {
Tcl_Interp *interp;
z_stream stream; /* The interface to the zlib library. */
int streamEnd; /* If we've got to end-of-stream. */
Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
Tcl_Obj *currentInput; /* Pointer to what is currently being
* inflated. */
Tcl_Size outPos; /* Index into output buffer to write to next. */
int mode; /* Either TCL_ZLIB_STREAM_DEFLATE or
* TCL_ZLIB_STREAM_INFLATE. */
int format; /* Flags from the TCL_ZLIB_FORMAT_* */
int level; /* Default 5, 0-9 */
int flush; /* Stores the flush param for deferred the
* decompression. */
int wbits; /* The encoded compression mode, so we can
* restart the stream if necessary. */
Tcl_Command cmd; /* Token for the associated Tcl command. */
Tcl_Obj *compDictObj; /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
int flags; /* Miscellaneous flag bits. */
GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header
* structure. */
} ZlibStreamHandle;
enum ZlibStreamHandleFlags {
DICT_TO_SET = 0x1 /* If we need to set a compression dictionary
* in the low-level engine at the next
* opportunity. */
};
/*
* Macros to make it clearer in some of the twiddlier accesses what is
* happening.
*/
#define IsRawStream(zshPtr) ((zshPtr)->format == TCL_ZLIB_FORMAT_RAW)
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
Tcl_Obj *compDictObj; /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
} ZlibChannelData;
/*
| | > > | | | | | | | | | < < < < < | 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 |
Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
Tcl_Obj *compDictObj; /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
} ZlibChannelData;
/*
* Value bits for the ZlibChannelData::flags field.
*/
enum ZlibChannelDataFlags {
ASYNC = 0x01, /* Set if this is an asynchronous channel. */
IN_HEADER = 0x02, /* Set if the inHeader field has been
* registered with the input compressor. */
OUT_HEADER = 0x04, /* Set if the outputHeader field has been
* registered with the output decompressor. */
STREAM_DECOMPRESS = 0x08, /* Set to signal decompress pending data. */
STREAM_DONE = 0x10 /* Set to signal stream end up to transform
* input. */
};
/*
* Size of buffers allocated by default, and the range it can be set to. The
* same sorts of values apply to streams, except with different limits (they
* permit byte-level activity). Channels always use bytes unless told to use
* larger buffers.
*/
|
| ︙ | ︙ | |||
183 184 185 186 187 188 189 | static inline int Deflate(z_streamp strm, void *bufferPtr, size_t bufferSize, int flush, size_t *writtenPtr); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); | | > | | > | | | | | | | > > > > > > > > > > > > > > > > > > > > | 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 |
static inline int Deflate(z_streamp strm, void *bufferPtr,
size_t bufferSize, int flush, size_t *writtenPtr);
static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
GzipHeader *headerPtr, int *extraSizePtr);
static int ZlibPushSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int ResultDecompress(ZlibChannelData *chanDataPtr,
char *buf, int toRead, int flush,
int *errorCodePtr);
static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
int mode, int format, int level, int limit,
Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr,
Tcl_Obj *compDictObj);
static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline void ZlibTransformEventTimerKill(
ZlibChannelData *chanDataPtr);
static void ZlibTransformTimerRun(void *clientData);
/*
* Type of zlib-based compressing and decompressing channels.
*/
static const Tcl_ChannelType zlibChannelType = {
"zlib",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
ZlibTransformInput,
ZlibTransformOutput,
NULL, /* Deprecated. */
ZlibTransformSetOption,
ZlibTransformGetOption,
ZlibTransformWatch,
ZlibTransformGetHandle,
ZlibTransformClose,
ZlibTransformBlockMode,
NULL, /* Flush proc. */
ZlibTransformEventHandler,
NULL, /* Seek proc. */
NULL, /* Thread action proc. */
NULL /* Truncate proc. */
};
/*
*----------------------------------------------------------------------
*
* Latin1 --
* Helper to definitely get the ISO 8859-1 encoding. It's internally
* defined by Tcl so this operation should always succeed.
*
*----------------------------------------------------------------------
*/
static inline Tcl_Encoding
Latin1(void)
{
Tcl_Encoding latin1enc = Tcl_GetEncoding(NULL, "iso8859-1");
if (latin1enc == NULL) {
Tcl_Panic("no latin-1 encoding");
}
return latin1enc;
}
/*
*----------------------------------------------------------------------
*
* ConvertError --
*
* Utility function for converting a zlib error into a Tcl error.
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
* Firstly, the case that is *different* because it's really coming
* from the OS and is just being reported via zlib. It should be
* really uncommon because Tcl handles all I/O rather than delegating
* it to zlib, but proving it can't happen is hard.
*/
case Z_ERRNO:
| | > | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
* Firstly, the case that is *different* because it's really coming
* from the OS and is just being reported via zlib. It should be
* really uncommon because Tcl handles all I/O rather than delegating
* it to zlib, but proving it can't happen is hard.
*/
case Z_ERRNO:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
Tcl_PosixError(interp), TCL_AUTO_LENGTH));
return;
/*
* Normal errors/conditions, some of which have additional detail and
* some which don't. (This is not defined by array lookup because zlib
* error codes are sometimes negative.)
*/
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
default:
codeStr = "UNKNOWN";
codeStr2 = codeStrBuf;
snprintf(codeStrBuf, sizeof(codeStrBuf), "%d", code);
break;
}
| | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
default:
codeStr = "UNKNOWN";
codeStr2 = codeStrBuf;
snprintf(codeStrBuf, sizeof(codeStrBuf), "%d", code);
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), TCL_AUTO_LENGTH));
/*
* Tricky point! We might pass NULL twice here (and will when the error
* type is known).
*/
Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, (char *)NULL);
}
static Tcl_Obj *
ConvertErrorToList(
int code, /* The zlib error code. */
uLong adler) /* The checksum expected (for Z_NEED_DICT) */
{
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
TclNewLiteralStringObj(objv[2], "BUF");
return Tcl_NewListObj(3, objv);
case Z_VERSION_ERROR:
TclNewLiteralStringObj(objv[2], "VERSION");
return Tcl_NewListObj(3, objv);
case Z_ERRNO:
TclNewLiteralStringObj(objv[2], "POSIX");
| | | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
TclNewLiteralStringObj(objv[2], "BUF");
return Tcl_NewListObj(3, objv);
case Z_VERSION_ERROR:
TclNewLiteralStringObj(objv[2], "VERSION");
return Tcl_NewListObj(3, objv);
case Z_ERRNO:
TclNewLiteralStringObj(objv[2], "POSIX");
objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), TCL_AUTO_LENGTH);
return Tcl_NewListObj(4, objv);
case Z_NEED_DICT:
TclNewLiteralStringObj(objv[2], "NEED_DICT");
TclNewIntObj(objv[3], (Tcl_WideInt) adler);
return Tcl_NewListObj(4, objv);
/*
* These should _not_ happen! This function is for dealing with error
* cases, not non-errors!
*/
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | /* *---------------------------------------------------------------------- * * GenerateHeader -- * * Function for creating a gzip header from the contents of a dictionary | | < < < < < < < < < < < < < < | < < < < < < < < < | | | | | | | | > | | | | | | | | | | | | | | | < < < < > > < < < < < | < < | < < | | | | < < < < | < < | | < | | | | | | | | 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 |
/*
*----------------------------------------------------------------------
*
* GenerateHeader --
*
* Function for creating a gzip header from the contents of a dictionary
* (as described in the documentation).
*
* Results:
* A Tcl result code.
*
* Side effects:
* Updates the fields of the given gz_header structure. Adds amount of
* extra space required for the header to the variable referenced by the
* extraSizePtr argument.
*
*----------------------------------------------------------------------
*/
static int
GenerateHeader(
Tcl_Interp *interp, /* Where to put error messages. */
Tcl_Obj *dictObj, /* The dictionary whose contents are to be
* parsed. */
GzipHeader *headerPtr, /* Where to store the parsed-out values. */
int *extraSizePtr) /* Variable to add the length of header
* strings (filename, comment) to. */
{
Tcl_Obj *value;
int len, result = TCL_ERROR;
Tcl_Size length;
Tcl_WideInt wideValue = 0;
const char *valueStr;
Tcl_Encoding latin1enc = Latin1();
static const char *const types[] = {
"binary", "text"
};
if (TclDictGet(interp, dictObj, "comment", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
valueStr = TclGetStringFromObj(value, &length);
result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length,
TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT,
&state, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN - 1, NULL,
&len, NULL);
if (result != TCL_OK) {
if (interp) {
if (result == TCL_CONVERT_UNKNOWN) {
Tcl_AppendResult(interp,
"Comment contains characters > 0xFF", (char *)NULL);
} else {
Tcl_AppendResult(interp, "Comment too large for zip",
(char *)NULL);
}
}
result = TCL_ERROR; /* TCL_CONVERT_* -> TCL_ERROR */
goto error;
}
headerPtr->nativeCommentBuf[len] = '\0';
headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf;
if (extraSizePtr != NULL) {
*extraSizePtr += len;
}
}
if (TclDictGet(interp, dictObj, "crc", &value) != TCL_OK) {
goto error;
} else if (value != NULL &&
Tcl_GetBooleanFromObj(interp, value, &headerPtr->header.hcrc)) {
goto error;
}
if (TclDictGet(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
valueStr = TclGetStringFromObj(value, &length);
result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length,
TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT,
&state, headerPtr->nativeFilenameBuf, MAXPATHLEN - 1, NULL,
&len, NULL);
if (result != TCL_OK) {
if (interp) {
if (result == TCL_CONVERT_UNKNOWN) {
Tcl_AppendResult(interp,
"Filename contains characters > 0xFF", (char *)NULL);
} else {
Tcl_AppendResult(interp,
"Filename too large for zip", (char *)NULL);
}
}
result = TCL_ERROR; /* TCL_CONVERT_* -> TCL_ERROR */
goto error;
}
headerPtr->nativeFilenameBuf[len] = '\0';
headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf;
if (extraSizePtr != NULL) {
*extraSizePtr += len;
}
}
if (TclDictGet(interp, dictObj, "os", &value) != TCL_OK) {
goto error;
} else if (value != NULL && Tcl_GetIntFromObj(interp, value,
&headerPtr->header.os) != TCL_OK) {
goto error;
}
/*
* Ignore the 'size' field, since that is controlled by the size of the
* input data.
*/
if (TclDictGet(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 (TclDictGet(interp, dictObj, "type", &value) != TCL_OK) {
goto error;
} else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types,
"type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) {
goto error;
}
result = TCL_OK;
error:
Tcl_FreeEncoding(latin1enc);
return result;
}
/*
*----------------------------------------------------------------------
*
* ExtractHeader --
*
* Take the values out of a gzip header and store them in a dictionary.
*
* Results:
* None.
*
* Side effects:
* Updates the dictionary, which must be writable (i.e. refCount < 2).
*
*----------------------------------------------------------------------
*/
static void
ExtractHeader(
gz_header *headerPtr, /* The gzip header to extract from. */
Tcl_Obj *dictObj) /* The dictionary to store in. */
{
Tcl_Encoding latin1enc = NULL;
/* RFC 1952 says that header strings are in
* ISO 8859-1 (LATIN-1). */
Tcl_DString tmp;
if (headerPtr->comment != Z_NULL) {
latin1enc = Latin1();
(void) Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment,
TCL_AUTO_LENGTH, &tmp);
TclDictPut(NULL, dictObj, "comment", Tcl_DStringToObj(&tmp));
}
TclDictPut(NULL, dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc));
if (headerPtr->name != Z_NULL) {
if (latin1enc == NULL) {
latin1enc = Latin1();
}
(void) Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name,
TCL_AUTO_LENGTH, &tmp);
TclDictPut(NULL, dictObj, "filename", Tcl_DStringToObj(&tmp));
}
if (headerPtr->os != 255) {
TclDictPut(NULL, dictObj, "os", Tcl_NewWideIntObj(headerPtr->os));
}
if (headerPtr->time != 0 /* magic - no time */) {
TclDictPut(NULL, dictObj, "time", Tcl_NewWideIntObj(headerPtr->time));
}
if (headerPtr->text != Z_UNKNOWN) {
TclDictPutString(NULL, dictObj, "type",
headerPtr->text ? "text" : "binary");
}
if (latin1enc != NULL) {
Tcl_FreeEncoding(latin1enc);
}
}
|
| ︙ | ︙ | |||
656 657 658 659 660 661 662 |
Deflate(
z_streamp strm,
void *bufferPtr,
size_t bufferSize,
int flush,
size_t *writtenPtr)
{
| < < | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
Deflate(
z_streamp strm,
void *bufferPtr,
size_t bufferSize,
int flush,
size_t *writtenPtr)
{
strm->next_out = (Bytef *) bufferPtr;
strm->avail_out = bufferSize;
int e = deflate(strm, flush);
if (writtenPtr != NULL) {
*writtenPtr = bufferSize - strm->avail_out;
}
return e;
}
static inline void
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
| | | 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
gzHeaderPtr = (GzipHeader *) Tcl_Alloc(sizeof(GzipHeader));
memset(gzHeaderPtr, 0, sizeof(GzipHeader));
if (GenerateHeader(interp, dictObj, gzHeaderPtr,
NULL) != TCL_OK) {
Tcl_Free(gzHeaderPtr);
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
| | | 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
gzHeaderPtr = (GzipHeader *) Tcl_Alloc(sizeof(GzipHeader));
memset(gzHeaderPtr, 0, sizeof(GzipHeader));
gzHeaderPtr->header.name = (Bytef *)
gzHeaderPtr->nativeFilenameBuf;
gzHeaderPtr->header.name_max = MAXPATHLEN - 1;
gzHeaderPtr->header.comment = (Bytef *)
gzHeaderPtr->nativeCommentBuf;
gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1;
|
| ︙ | ︙ | |||
793 794 795 796 797 798 799 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
| | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
zshPtr = (ZlibStreamHandle *) Tcl_Alloc(sizeof(ZlibStreamHandle));
zshPtr->interp = interp;
zshPtr->mode = mode;
zshPtr->format = format;
zshPtr->level = level;
zshPtr->wbits = wbits;
zshPtr->currentInput = NULL;
zshPtr->streamEnd = 0;
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 |
}
/*
* I could do all this in C, but this is easier.
*/
if (interp != NULL) {
| | > | | | 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 |
}
/*
* I could do all this in C, but this is easier.
*/
if (interp != NULL) {
if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter",
TCL_AUTO_LENGTH, 0) != TCL_OK) {
goto error;
}
Tcl_DStringInit(&cmdname);
TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_");
TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname),
NULL, 0) != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"BUG: Stream command name already exists", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", (char *)NULL);
Tcl_DStringFree(&cmdname);
goto error;
}
Tcl_ResetResult(interp);
/*
* Create the command.
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 | * Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit * *---------------------------------------------------------------------- */ static void ZlibStreamCmdDelete( | | | | 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
* Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit
*
*----------------------------------------------------------------------
*/
static void
ZlibStreamCmdDelete(
void *clientData)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) clientData;
zshPtr->cmd = NULL;
ZlibStreamCleanup(zshPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1162 1163 1164 1165 1166 1167 1168 |
*----------------------------------------------------------------------
*/
int
Tcl_ZlibStreamChecksum(
Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */
{
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
*----------------------------------------------------------------------
*/
int
Tcl_ZlibStreamChecksum(
Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)zshandle;
return zshPtr->stream.adler;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 |
Tcl_Size size = 0;
size_t outSize, toStore;
unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
| | | | 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 |
Tcl_Size size = 0;
size_t outSize, toStore;
unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", (char *)NULL);
}
return TCL_ERROR;
}
bytes = Tcl_GetBytesFromObj(zshPtr->interp, data, &size);
if (bytes == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
| | | 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
dataTmp = (char *) Tcl_Alloc(outSize);
while (1) {
e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore);
/*
* Test if we've filled the buffer up and have to ask deflate() to
* give us some more. Note that the condition for needing to
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
*/
AppendByteArray(zshPtr->outData, dataTmp, outSize);
if (outSize < BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
/* There may be *lots* of data left to output... */
| | | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
*/
AppendByteArray(zshPtr->outData, dataTmp, outSize);
if (outSize < BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
/* There may be *lots* of data left to output... */
dataTmp = (char *) Tcl_Realloc(dataTmp, outSize);
}
}
/*
* And append the final data block to the outData list.
*/
|
| ︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 |
*----------------------------------------------------------------------
*/
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* A place to append the data. */
| | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
*----------------------------------------------------------------------
*/
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* A place to append the data. */
Tcl_Size count) /* Number of bytes to grab as a maximum, you
* may get less! */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
int e;
Tcl_Size listLen, i, itemLen = 0, dataPos = 0;
Tcl_Obj *itemObj;
unsigned char *dataPtr, *itemPtr;
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 | count = MAX_BUFFER_SIZE; } /* * Prepare the place to store the data. */ | | | | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
count = MAX_BUFFER_SIZE;
}
/*
* Prepare the place to store the data.
*/
dataPtr = Tcl_SetByteArrayLength(data, existing + count);
dataPtr += existing;
zshPtr->stream.next_out = dataPtr;
zshPtr->stream.avail_out = count;
if (zshPtr->stream.avail_in == 0) {
/*
* zlib will probably need more data to decompress.
*/
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = NULL;
}
TclListObjLength(NULL, zshPtr->inData, &listLen);
if (listLen > 0) {
/*
* There is more input available, get it from the list and
* give it to zlib. At this point, the data must not be shared
* since we require the bytearray representation to not vanish
* under our feet. [Bug 3081008]
*/
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 |
if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e == Z_OK) {
DictWasSet(zshPtr);
e = inflate(&zshPtr->stream, zshPtr->flush);
}
};
| | | | | 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 |
if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e == Z_OK) {
DictWasSet(zshPtr);
e = inflate(&zshPtr->stream, zshPtr->flush);
}
};
TclListObjLength(NULL, zshPtr->inData, &listLen);
while ((zshPtr->stream.avail_out > 0)
&& (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) {
/*
* State: We have not satisfied the request yet and there may be
* more to inflate.
*/
if (zshPtr->stream.avail_in > 0) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"unexpected zlib internal state during"
" decompression", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
(char *)NULL);
}
Tcl_SetByteArrayLength(data, existing);
return TCL_ERROR;
}
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
|
| ︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 |
*/
do {
e = inflate(&zshPtr->stream, zshPtr->flush);
if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) {
break;
}
| | | 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 |
*/
do {
e = inflate(&zshPtr->stream, zshPtr->flush);
if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) {
break;
}
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
DictWasSet(zshPtr);
} while (e == Z_OK);
}
if (zshPtr->stream.avail_out > 0) {
Tcl_SetByteArrayLength(data,
existing + count - zshPtr->stream.avail_out);
}
|
| ︙ | ︙ | |||
1535 1536 1537 1538 1539 1540 1541 |
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
| | | 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 |
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
TclListObjLength(NULL, zshPtr->outData, &listLen);
if (count < 0) {
count = 0;
for (i=0; i<listLen; i++) {
Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
(void) Tcl_GetBytesFromObj(NULL, itemObj, &itemLen);
if (i == 0) {
count += itemLen - zshPtr->outPos;
|
| ︙ | ︙ | |||
1557 1558 1559 1560 1561 1562 1563 | * Prepare the place to store the data. */ dataPtr = Tcl_SetByteArrayLength(data, existing + count); dataPtr += existing; while ((count > dataPos) && | | | | 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 |
* Prepare the place to store the data.
*/
dataPtr = Tcl_SetByteArrayLength(data, existing + count);
dataPtr += existing;
while ((count > dataPos) &&
(TclListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK)
&& (listLen > 0)) {
/*
* Get the next chunk off our list of chunks and grab the data out
* of it.
*/
Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
itemPtr = Tcl_GetBytesFromObj(NULL, itemObj, &itemLen);
if ((itemLen - zshPtr->outPos) >= (count - dataPos)) {
Tcl_Size len = count - dataPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
zshPtr->outPos += len;
dataPos += len;
if (zshPtr->outPos == itemLen) {
zshPtr->outPos = 0;
|
| ︙ | ︙ | |||
1813 1814 1815 1816 1817 1818 1819 |
"TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
"TCL_ZLIB_FORMAT_AUTO");
}
if (gzipHeaderDictObj) {
headerPtr = &header;
memset(headerPtr, 0, sizeof(gz_header));
| | | | | | | | | 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 |
"TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
"TCL_ZLIB_FORMAT_AUTO");
}
if (gzipHeaderDictObj) {
headerPtr = &header;
memset(headerPtr, 0, sizeof(gz_header));
nameBuf = (char *) Tcl_Alloc(MAXPATHLEN);
header.name = (Bytef *) nameBuf;
header.name_max = MAXPATHLEN - 1;
commentBuf = (char *) Tcl_Alloc(MAX_COMMENT_LEN);
header.comment = (Bytef *) commentBuf;
header.comm_max = MAX_COMMENT_LEN - 1;
}
if (bufferSize < 1) {
/*
* Start with a buffer (up to) 3 times the size of the input data.
*/
if (inLen < 32 * 1024 * 1024) {
bufferSize = 3 * inLen;
} else if (inLen < 256 * 1024 * 1024) {
bufferSize = 2 * inLen;
} else {
bufferSize = inLen;
}
}
TclNewObj(obj);
outData = Tcl_SetByteArrayLength(obj, bufferSize);
memset(&stream, 0, sizeof(z_stream));
stream.avail_in = inLen+1; /* +1 because zlib can "over-request"
* input (but ignore it!) */
stream.next_in = inData;
stream.avail_out = bufferSize;
stream.next_out = outData;
/*
* Initialize zlib for decompression.
*/
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 |
if ((stream.avail_in == 0) && (stream.avail_out > 0)) {
e = Z_STREAM_ERROR;
break;
}
newBufferSize = bufferSize + 5 * stream.avail_in;
if (newBufferSize == bufferSize) {
| | | 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 |
if ((stream.avail_in == 0) && (stream.avail_out > 0)) {
e = Z_STREAM_ERROR;
break;
}
newBufferSize = bufferSize + 5 * stream.avail_in;
if (newBufferSize == bufferSize) {
newBufferSize = bufferSize + 1000;
}
newOutData = Tcl_SetByteArrayLength(obj, newBufferSize);
/*
* Set next out to the same offset in the new location.
*/
|
| ︙ | ︙ | |||
1919 1920 1921 1922 1923 1924 1925 |
/*
* Reduce the BA length to the actual data length produced by deflate.
*/
Tcl_SetByteArrayLength(obj, stream.total_out);
if (headerPtr != NULL) {
ExtractHeader(&header, gzipHeaderDictObj);
| | | 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 |
/*
* Reduce the BA length to the actual data length produced by deflate.
*/
Tcl_SetByteArrayLength(obj, stream.total_out);
if (headerPtr != NULL) {
ExtractHeader(&header, gzipHeaderDictObj);
TclDictPut(NULL, gzipHeaderDictObj, "size",
Tcl_NewWideIntObj(stream.total_out));
Tcl_Free(nameBuf);
Tcl_Free(commentBuf);
}
Tcl_SetObjResult(interp, obj);
return TCL_OK;
|
| ︙ | ︙ | |||
1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 |
/*
*----------------------------------------------------------------------
*
* ZlibCmd --
*
* Implementation of the [zlib] command.
*
*----------------------------------------------------------------------
*/
static int
ZlibCmd(
TCL_UNUSED(void *),
| > > | 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 |
/*
*----------------------------------------------------------------------
*
* ZlibCmd --
*
* Implementation of the [zlib] command.
*
* TODO: Convert this to an ensemble.
*
*----------------------------------------------------------------------
*/
static int
ZlibCmd(
TCL_UNUSED(void *),
|
| ︙ | ︙ | |||
2013 2014 2015 2016 2017 2018 2019 |
}
if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,
&command) != TCL_OK) {
return TCL_ERROR;
}
switch (command) {
| | | | | | | | | | | | | | | | | | 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 |
}
if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,
&command) != TCL_OK) {
return TCL_ERROR;
}
switch (command) {
case CMD_ADLER: /* adler32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
data = Tcl_GetBytesFromObj(interp, objv[2], &dlen);
if (data == NULL) {
return TCL_ERROR;
}
if (objc > 3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_ZlibAdler32(start, data, dlen)));
return TCL_OK;
case CMD_CRC: /* crc32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
data = Tcl_GetBytesFromObj(interp, objv[2], &dlen);
if (data == NULL) {
return TCL_ERROR;
}
if (objc > 3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibCRC32(0, NULL, 0);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_ZlibCRC32(start, data, dlen)));
return TCL_OK;
case CMD_DEFLATE: /* deflate data ?level?
* -> rawCompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level < 0 || level > 9) {
goto badLevel;
}
}
return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], level,
NULL);
case CMD_COMPRESS: /* compress data ?level?
* -> zlibCompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level < 0 || level > 9) {
goto badLevel;
}
}
return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], level,
NULL);
case CMD_GZIP: /* gzip data ?level?
* -> gzippedCompressedData */
headerDictObj = NULL;
/*
* Legacy argument format support.
*/
if (objc == 4
|
| ︙ | ︙ | |||
2119 2120 2121 2122 2123 2124 2125 |
if (Tcl_GetIndexFromObj(interp, objv[i], gzipopts, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0:
| | | | | | < | | | | | | < | | | < > | > | | | 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 |
if (Tcl_GetIndexFromObj(interp, objv[i], gzipopts, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0:
headerDictObj = objv[i + 1];
break;
case 1:
if (Tcl_GetIntFromObj(interp, objv[i + 1],
&level) != TCL_OK) {
return TCL_ERROR;
}
if (level < 0 || level > 9) {
extraInfoStr = "\n (in -level option)";
goto badLevel;
}
break;
}
}
return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], level,
headerDictObj);
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;
}
buffersize = wideLen;
}
return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2],
buffersize, NULL);
case CMD_GUNZIP: { /* gunzip gzippeddata ?-headerVar varName?
* -> decompressedData */
Tcl_Obj *headerVarObj;
if (objc < 3 || objc > 5 || ((objc & 1) == 0)) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?");
return TCL_ERROR;
}
headerDictObj = headerVarObj = NULL;
for (i=3 ; i<objc ; i+=2) {
static const char *const gunzipopts[] = {
"-buffersize", "-headerVar", NULL
};
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;
}
buffersize = wideLen;
break;
case 1:
headerVarObj = objv[i + 1];
TclNewObj(headerDictObj);
break;
}
}
if (Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2],
buffersize, headerDictObj) != TCL_OK) {
if (headerDictObj) {
TclDecrRefCount(headerDictObj);
}
return TCL_ERROR;
}
if (headerVarObj != NULL && Tcl_ObjSetVar2(interp, headerVarObj, NULL,
headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
return TCL_OK;
}
case CMD_STREAM: /* stream deflate/inflate/...gunzip options...
* -> handleCmd */
return ZlibStreamSubcmd(interp, objc, objv);
case CMD_PUSH: /* push mode channel options...
* -> channel */
return ZlibPushSubcmd(interp, objc, objv);
}
return TCL_ERROR;
badLevel:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"level must be 0 to 9", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", (char *)NULL);
if (extraInfoStr) {
Tcl_AddErrorInfo(interp, extraInfoStr);
}
return TCL_ERROR;
badBuffer:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"buffer size must be %d to %d",
MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ZlibStreamSubcmd --
|
| ︙ | ︙ | |||
2366 2367 2368 2369 2370 2371 2372 |
*/
for (i=3 ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObjStruct(interp, objv[i], desc,
sizeof(OptDescriptor), "option", 0, &option) != TCL_OK) {
return TCL_ERROR;
}
| | | > | | 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 |
*/
for (i=3 ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObjStruct(interp, objv[i], desc,
sizeof(OptDescriptor), "option", 0, &option) != TCL_OK) {
return TCL_ERROR;
}
obj[desc[option].offset] = objv[i + 1];
}
/*
* If a compression level was given, parse it (integral: 0..9). Otherwise
* use the default.
*/
if (levelObj == NULL) {
level = Z_DEFAULT_COMPRESSION;
} else if (Tcl_GetIntFromObj(interp, levelObj, &level) != TCL_OK) {
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"level must be 0 to 9", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", (char *)NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
if (compDictObj) {
if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (Tcl_Size *)NULL)) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
2488 2489 2490 2491 2492 2493 2494 |
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_GZIP;
break;
default:
Tcl_Panic("should be unreachable");
}
| | | > | | > | | | | | | | | | | | | | | | > | 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 |
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_GZIP;
break;
default:
Tcl_Panic("should be unreachable");
}
if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK) {
return TCL_ERROR;
}
/*
* Sanity checks.
*/
if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"compression may only be applied to writable channels",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", (char *)NULL);
return TCL_ERROR;
}
if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"decompression may only be applied to readable channels",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", (char *)NULL);
return TCL_ERROR;
}
/*
* Parse options.
*/
level = Z_DEFAULT_COMPRESSION;
for (i=4 ; i<objc ; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
if (++i > objc - 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value missing for %s option", pushOptions[option]));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (char *)NULL);
return TCL_ERROR;
}
switch (option) {
case poHeader: /* -header headerDict */
headerObj = objv[i];
if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) {
goto genericOptionError;
}
break;
case poLevel: /* -level compLevel */
if (Tcl_GetIntFromObj(interp, objv[i], (int *) &level) != TCL_OK) {
goto genericOptionError;
}
if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"level must be 0 to 9", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL",
(char *)NULL);
goto genericOptionError;
}
break;
case poLimit: /* -limit numBytes */
if (Tcl_GetIntFromObj(interp, objv[i], (int *) &limit) != TCL_OK) {
goto genericOptionError;
}
if (limit < 1 || limit > MAX_BUFFER_SIZE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"read ahead limit must be 1 to %d",
MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (char *)NULL);
goto genericOptionError;
}
break;
case poDictionary: /* -dictionary compDict */
if (format == TCL_ZLIB_FORMAT_GZIP) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"a compression dictionary may not be set in the "
"gzip format", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", (char *)NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj,
(Tcl_Size *)NULL))) {
return TCL_ERROR;
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2599 2600 2601 2602 2603 2604 2605 | * Implementation of the commands returned by [zlib stream]. * *---------------------------------------------------------------------- */ static int ZlibStreamCmd( | | | | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 |
* Implementation of the commands returned by [zlib stream].
*
*----------------------------------------------------------------------
*/
static int
ZlibStreamCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream) clientData;
int count, code;
Tcl_Obj *obj;
static const char *const cmds[] = {
"add", "checksum", "close", "eof", "finalize", "flush",
"fullflush", "get", "header", "put", "reset",
NULL
};
|
| ︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 |
}
return Tcl_ZlibStreamClose(zstream);
case zs_eof: /* $strm eof */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
| | | | | | | | | | | | | | | | | | | | | 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 |
}
return Tcl_ZlibStreamClose(zstream);
case zs_eof: /* $strm eof */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_ZlibStreamEof(zstream)));
return TCL_OK;
case zs_checksum: /* $strm checksum */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
(uint32_t) Tcl_ZlibStreamChecksum(zstream)));
return TCL_OK;
case zs_reset: /* $strm reset */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return Tcl_ZlibStreamReset(zstream);
}
return TCL_OK;
}
static int
ZlibStreamAddCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream) clientData;
int code, buffersize = -1, flush = -1, i;
Tcl_Obj *obj, *compDictObj = NULL;
static const char *const add_options[] = {
"-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL
};
enum addOptions {
ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush
} index;
for (i=2; i<objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case ao_flush: /* -flush */
if (flush >= 0) {
flush = -2;
} else {
flush = Z_SYNC_FLUSH;
}
break;
case ao_fullflush: /* -fullflush */
if (flush >= 0) {
flush = -2;
} else {
flush = Z_FULL_FLUSH;
}
break;
case ao_finalize: /* -finalize */
if (flush >= 0) {
flush = -2;
} else {
flush = Z_FINISH;
}
break;
case ao_buffer: /* -buffer bufferSize */
if (i == objc - 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-buffer\" option must be followed by integer "
"decompression buffersize", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (char *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"buffer size must be 1 to %d",
MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (char *)NULL);
return TCL_ERROR;
}
break;
case ao_dictionary: /* -dictionary compDict */
if (i == objc - 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-dictionary\" option must be followed by"
" compression dictionary bytes", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (char *)NULL);
return TCL_ERROR;
}
compDictObj = objv[++i];
break;
}
if (flush == -2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-flush\", \"-fullflush\" and \"-finalize\" options"
" are mutually exclusive", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", (char *)NULL);
return TCL_ERROR;
}
}
if (flush == -1) {
flush = 0;
}
|
| ︙ | ︙ | |||
2832 2833 2834 2835 2836 2837 2838 |
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
* Send the data to the stream core, along with any flushing directive.
*/
| | | | | | | | | | | | | | 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 |
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
* Send the data to the stream core, along with any flushing directive.
*/
if (Tcl_ZlibStreamPut(zstream, objv[objc - 1], flush) != TCL_OK) {
return TCL_ERROR;
}
/*
* Get such data out as we can (up to the requested length).
*/
TclNewObj(obj);
code = Tcl_ZlibStreamGet(zstream, obj, buffersize);
if (code == TCL_OK) {
Tcl_SetObjResult(interp, obj);
} else {
TclDecrRefCount(obj);
}
return code;
}
static int
ZlibStreamPutCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream) clientData;
int flush = -1, i;
Tcl_Obj *compDictObj = NULL;
static const char *const put_options[] = {
"-dictionary", "-finalize", "-flush", "-fullflush", NULL
};
enum putOptions {
po_dictionary, po_finalize, po_flush, po_fullflush
} index;
for (i=2; i<objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case po_flush: /* -flush */
if (flush >= 0) {
flush = -2;
} else {
flush = Z_SYNC_FLUSH;
}
break;
case po_fullflush: /* -fullflush */
if (flush >= 0) {
flush = -2;
} else {
flush = Z_FULL_FLUSH;
}
break;
case po_finalize: /* -finalize */
if (flush >= 0) {
flush = -2;
} else {
flush = Z_FINISH;
}
break;
case po_dictionary: /* -dictionary compDict */
if (i == objc - 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-dictionary\" option must be followed by"
" compression dictionary bytes", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (char *)NULL);
return TCL_ERROR;
}
compDictObj = objv[++i];
break;
}
if (flush == -2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-flush\", \"-fullflush\" and \"-finalize\" options"
" are mutually exclusive", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", (char *)NULL);
return TCL_ERROR;
}
}
if (flush == -1) {
flush = 0;
}
|
| ︙ | ︙ | |||
2938 2939 2940 2941 2942 2943 2944 |
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
* Send the data to the stream core, along with any flushing directive.
*/
| | | | | > | > > > > > > > > > > > | | | | | | | | | | > | | > > | | | | | | | | | | | | | | | | | | | | > | | | | > | | | > < | | | | < | | | | 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 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 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 |
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
* Send the data to the stream core, along with any flushing directive.
*/
return Tcl_ZlibStreamPut(zstream, objv[objc - 1], flush);
}
static int
ZlibStreamHeaderCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) clientData;
Tcl_Obj *resultObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
} else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE
|| zshPtr->format != TCL_ZLIB_FORMAT_GZIP) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"only gunzip streams can produce header information",
TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", (char *)NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* Set of functions to support channel stacking.
*----------------------------------------------------------------------
*/
static inline int
HaveFlag(
ZlibChannelData *chanDataPtr,
int flag)
{
return (chanDataPtr->flags & flag) != 0;
}
/*
*
* ZlibTransformClose --
*
* How to shut down a stacked compressing/decompressing transform.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformClose(
void *instanceData,
Tcl_Interp *interp,
int flags)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
int e, result = TCL_OK;
size_t written;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Delete the support timer.
*/
ZlibTransformEventTimerKill(chanDataPtr);
/*
* Flush any data waiting to be compressed.
*/
if (chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
chanDataPtr->outStream.avail_in = 0;
do {
e = Deflate(&chanDataPtr->outStream, chanDataPtr->outBuffer,
chanDataPtr->outAllocated, Z_FINISH, &written);
/*
* Can't be sure that deflate() won't declare the buffer to be
* full (with Z_BUF_ERROR) so handle that case.
*/
if (e == Z_BUF_ERROR) {
e = Z_OK;
written = chanDataPtr->outAllocated;
}
if (e != Z_OK && e != Z_STREAM_END) {
/* TODO: is this the right way to do errors on close? */
if (!TclInThreadExit()) {
ConvertError(interp, e, chanDataPtr->outStream.adler);
}
result = TCL_ERROR;
break;
}
if (written && Tcl_WriteRaw(chanDataPtr->parent,
chanDataPtr->outBuffer, written) == TCL_IO_FAILURE) {
/* TODO: is this the right way to do errors on close?
* Note: when close is called from FinalizeIOSubsystem then
* interp may be NULL */
if (!TclInThreadExit() && interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error while finalizing file: %s",
Tcl_PosixError(interp)));
}
result = TCL_ERROR;
break;
}
} while (e != Z_STREAM_END);
(void) deflateEnd(&chanDataPtr->outStream);
} else {
/*
* If we have unused bytes from the read input (overshot by
* Z_STREAM_END or on possible error), unget them back to the parent
* channel, so that they appear as not being read yet.
*/
if (chanDataPtr->inStream.avail_in) {
Tcl_Ungets(chanDataPtr->parent,
(char *) chanDataPtr->inStream.next_in,
chanDataPtr->inStream.avail_in, 0);
}
(void) inflateEnd(&chanDataPtr->inStream);
}
/*
* Release all memory.
*/
if (chanDataPtr->compDictObj) {
Tcl_DecrRefCount(chanDataPtr->compDictObj);
chanDataPtr->compDictObj = NULL;
}
if (chanDataPtr->inBuffer) {
Tcl_Free(chanDataPtr->inBuffer);
chanDataPtr->inBuffer = NULL;
}
if (chanDataPtr->outBuffer) {
Tcl_Free(chanDataPtr->outBuffer);
chanDataPtr->outBuffer = NULL;
}
Tcl_Free(chanDataPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformInput --
*
* Reader filter that does decompression.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformInput(
void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
Tcl_DriverInputProc *inProc =
Tcl_ChannelInputProc(Tcl_GetChannelType(chanDataPtr->parent));
int readBytes, gotBytes;
if (chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
return inProc(Tcl_GetChannelInstanceData(chanDataPtr->parent), buf,
toRead, errorCodePtr);
}
gotBytes = 0;
readBytes = chanDataPtr->inStream.avail_in; /* how many bytes in buffer now */
while (!HaveFlag(chanDataPtr, STREAM_DONE) && toRead > 0) {
unsigned int n;
int decBytes;
/* if starting from scratch or continuation after full decompression */
if (!chanDataPtr->inStream.avail_in) {
/* buffer to start, we can read to whole available buffer */
chanDataPtr->inStream.next_in = (Bytef *) chanDataPtr->inBuffer;
}
/*
* If done - no read needed anymore, check we have to copy rest of
* decompressed data, otherwise return with size (or 0 for Eof)
*/
if (HaveFlag(chanDataPtr, STREAM_DECOMPRESS)) {
goto copyDecompressed;
}
/*
* The buffer is exhausted, but the caller wants even more. We now
* have to go to the underlying channel, get more bytes and then
* transform them for delivery. We may not get what we want (full EOF
* or temporarily out of data).
*/
/* Check free buffer size and adjust size of next chunk to read. */
n = chanDataPtr->inAllocated - ((char *)
chanDataPtr->inStream.next_in - chanDataPtr->inBuffer);
if (n <= 0) {
/* Normally unreachable: not enough input buffer to uncompress.
* Todo: firstly try to realloc inBuffer upto MAX_BUFFER_SIZE.
*/
*errorCodePtr = ENOBUFS;
return -1;
}
if (n > chanDataPtr->readAheadLimit) {
n = chanDataPtr->readAheadLimit;
}
readBytes = Tcl_ReadRaw(chanDataPtr->parent,
(char *) chanDataPtr->inStream.next_in, n);
/*
* Three cases here:
* 1. Got some data from the underlying channel (readBytes > 0) so
* it should be fed through the decompression engine.
* 2. Got an error (readBytes == -1) which we should report up except
* for the case where we can convert it to a short read.
* 3. Got an end-of-data from EOF or blocking (readBytes == 0). If
* it is EOF, try flushing the data out of the decompressor.
*/
if (readBytes == -1) {
/* See ReflectInput() in tclIORTrans.c */
if (Tcl_InputBlocked(chanDataPtr->parent) && (gotBytes > 0)) {
break;
}
*errorCodePtr = Tcl_GetErrno();
return -1;
}
/* more bytes (or Eof if readBytes == 0) */
chanDataPtr->inStream.avail_in += readBytes;
copyDecompressed:
/*
* Transform the read chunk, if not empty. Anything we get
* back is a transformation result to be put into our buffers, and
* the next iteration will put it into the result.
* For the case readBytes is 0 which signaling Eof in parent, the
* partial data waiting is converted and returned.
*/
decBytes = ResultDecompress(chanDataPtr, buf, toRead,
(readBytes != 0) ? Z_NO_FLUSH : Z_SYNC_FLUSH, errorCodePtr);
if (decBytes == -1) {
return -1;
}
gotBytes += decBytes;
buf += decBytes;
toRead -= decBytes;
if ((decBytes == 0) || HaveFlag(chanDataPtr, STREAM_DECOMPRESS)) {
/*
* The drain delivered nothing (or buffer too small to decompress).
* Time to deliver what we've got.
*/
if (!gotBytes && !HaveFlag(chanDataPtr, STREAM_DONE)) {
/* if no-data, but not ready - avoid signaling Eof,
* continue in blocking mode, otherwise EAGAIN */
if (Tcl_InputBlocked(chanDataPtr->parent)) {
continue;
}
*errorCodePtr = EAGAIN;
return -1;
}
break;
}
|
| ︙ | ︙ | |||
3227 3228 3229 3230 3231 3232 3233 |
static int
ZlibTransformOutput(
void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | | | | | | | | | | > | | | > | | | | | | | | > | | 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 |
static int
ZlibTransformOutput(
void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
Tcl_DriverOutputProc *outProc =
Tcl_ChannelOutputProc(Tcl_GetChannelType(chanDataPtr->parent));
int e;
size_t produced;
Tcl_Obj *errObj;
if (chanDataPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
return outProc(Tcl_GetChannelInstanceData(chanDataPtr->parent), buf,
toWrite, errorCodePtr);
}
/*
* No zero-length writes. Flushes must be explicit.
*/
if (toWrite == 0) {
return 0;
}
chanDataPtr->outStream.next_in = (Bytef *) buf;
chanDataPtr->outStream.avail_in = toWrite;
while (chanDataPtr->outStream.avail_in > 0) {
e = Deflate(&chanDataPtr->outStream, chanDataPtr->outBuffer,
chanDataPtr->outAllocated, Z_NO_FLUSH, &produced);
if (e != Z_OK || produced == 0) {
break;
}
if (Tcl_WriteRaw(chanDataPtr->parent, chanDataPtr->outBuffer,
produced) == TCL_IO_FAILURE) {
*errorCodePtr = Tcl_GetErrno();
return -1;
}
}
if (e == Z_OK) {
return toWrite - chanDataPtr->outStream.avail_in;
}
errObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj(
"-errorcode", TCL_AUTO_LENGTH));
Tcl_ListObjAppendElement(NULL, errObj,
ConvertErrorToList(e, chanDataPtr->outStream.adler));
Tcl_ListObjAppendElement(NULL, errObj,
Tcl_NewStringObj(chanDataPtr->outStream.msg, TCL_AUTO_LENGTH));
Tcl_SetChannelError(chanDataPtr->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformFlush --
*
* How to perform a flush of a compressing transform.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformFlush(
Tcl_Interp *interp,
ZlibChannelData *chanDataPtr,
int flushType)
{
int e;
size_t len;
chanDataPtr->outStream.avail_in = 0;
do {
/*
* Get the bytes to go out of the compression engine.
*/
e = Deflate(&chanDataPtr->outStream, chanDataPtr->outBuffer,
chanDataPtr->outAllocated, flushType, &len);
if (e != Z_OK && e != Z_BUF_ERROR) {
ConvertError(interp, e, chanDataPtr->outStream.adler);
return TCL_ERROR;
}
/*
* Write the bytes we've received to the next layer.
*/
if (len > 0 && Tcl_WriteRaw(chanDataPtr->parent, chanDataPtr->outBuffer,
len) == TCL_IO_FAILURE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"problem flushing channel: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3350 3351 3352 3353 3354 3355 3356 |
static int
ZlibTransformSetOption( /* not used */
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
| | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 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 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 |
static int
ZlibTransformSetOption( /* not used */
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
Tcl_DriverSetOptionProc *setOptionProc =
Tcl_ChannelSetOptionProc(Tcl_GetChannelType(chanDataPtr->parent));
static const char *compressChanOptions = "dictionary flush";
static const char *gzipChanOptions = "flush";
static const char *decompressChanOptions = "dictionary limit";
static const char *gunzipChanOptions = "flush limit";
int haveFlushOpt = (chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE);
if (optionName && (strcmp(optionName, "-dictionary") == 0)
&& (chanDataPtr->format != TCL_ZLIB_FORMAT_GZIP)) {
Tcl_Obj *compDictObj;
int code;
TclNewStringObj(compDictObj, value, strlen(value));
Tcl_IncrRefCount(compDictObj);
if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (Tcl_Size *)NULL)) {
Tcl_DecrRefCount(compDictObj);
return TCL_ERROR;
}
if (chanDataPtr->compDictObj) {
TclDecrRefCount(chanDataPtr->compDictObj);
}
chanDataPtr->compDictObj = compDictObj;
code = Z_OK;
if (chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
code = SetDeflateDictionary(&chanDataPtr->outStream, compDictObj);
if (code != Z_OK) {
ConvertError(interp, code, chanDataPtr->outStream.adler);
return TCL_ERROR;
}
} else if (chanDataPtr->format == TCL_ZLIB_FORMAT_RAW) {
code = SetInflateDictionary(&chanDataPtr->inStream, compDictObj);
if (code != Z_OK) {
ConvertError(interp, code, chanDataPtr->inStream.adler);
return TCL_ERROR;
}
}
return TCL_OK;
}
if (haveFlushOpt) {
if (optionName && strcmp(optionName, "-flush") == 0) {
int flushType;
if (value[0] == 'f' && strcmp(value, "full") == 0) {
flushType = Z_FULL_FLUSH;
} else if (value[0] == 's' && strcmp(value, "sync") == 0) {
flushType = Z_SYNC_FLUSH;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown -flush type \"%s\": must be full or sync",
value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", (char *)NULL);
return TCL_ERROR;
}
/*
* Try to actually do the flush now.
*/
return ZlibTransformFlush(interp, chanDataPtr, flushType);
}
} else {
if (optionName && strcmp(optionName, "-limit") == 0) {
int newLimit;
if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) {
return TCL_ERROR;
} else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-limit must be between 1 and 65536", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT",
(char *)NULL);
return TCL_ERROR;
}
}
}
if (setOptionProc == NULL) {
if (chanDataPtr->format == TCL_ZLIB_FORMAT_GZIP) {
return Tcl_BadChannelOption(interp, optionName,
(chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE)
? gzipChanOptions : gunzipChanOptions);
} else {
return Tcl_BadChannelOption(interp, optionName,
(chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE)
? compressChanOptions : decompressChanOptions);
}
}
/*
* Pass all unknown options down, to deeper transforms and/or the base
* channel.
*/
return setOptionProc(Tcl_GetChannelInstanceData(chanDataPtr->parent),
interp, optionName, value);
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformGetOption --
*
* Reading side of [fconfigure] on our channel.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformGetOption(
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
Tcl_DriverGetOptionProc *getOptionProc =
Tcl_ChannelGetOptionProc(Tcl_GetChannelType(chanDataPtr->parent));
static const char *compressChanOptions = "checksum dictionary";
static const char *gzipChanOptions = "checksum";
static const char *decompressChanOptions = "checksum dictionary limit";
static const char *gunzipChanOptions = "checksum header limit";
/*
* The "crc" option reports the current CRC (calculated with the Adler32
* or CRC32 algorithm according to the format) given the data that has
* been processed so far.
*/
if (optionName == NULL || strcmp(optionName, "-checksum") == 0) {
uLong crc;
char buf[12];
if (chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
crc = chanDataPtr->outStream.adler;
} else {
crc = chanDataPtr->inStream.adler;
}
snprintf(buf, sizeof(buf), "%lu", crc);
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-checksum");
Tcl_DStringAppendElement(dsPtr, buf);
} else {
Tcl_DStringAppend(dsPtr, buf, TCL_AUTO_LENGTH);
return TCL_OK;
}
}
if ((chanDataPtr->format != TCL_ZLIB_FORMAT_GZIP) &&
(optionName == NULL || strcmp(optionName, "-dictionary") == 0)) {
/*
* Embedded NUL bytes are ok; they'll be C080-encoded.
*/
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-dictionary");
if (chanDataPtr->compDictObj) {
Tcl_DStringAppendElement(dsPtr,
TclGetString(chanDataPtr->compDictObj));
} else {
Tcl_DStringAppendElement(dsPtr, "");
}
} else {
if (chanDataPtr->compDictObj) {
Tcl_Size length;
const char *str = TclGetStringFromObj(chanDataPtr->compDictObj,
&length);
Tcl_DStringAppend(dsPtr, str, length);
}
return TCL_OK;
}
}
/*
* The "header" option, which is only valid on inflating gzip channels,
* reports the header that has been read from the start of the stream.
*/
if (HaveFlag(chanDataPtr, IN_HEADER) && ((optionName == NULL) ||
(strcmp(optionName, "-header") == 0))) {
Tcl_Obj *tmpObj;
TclNewObj(tmpObj);
ExtractHeader(&chanDataPtr->inHeader.header, tmpObj);
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-header");
Tcl_DStringAppendElement(dsPtr, TclGetString(tmpObj));
Tcl_DecrRefCount(tmpObj);
} else {
TclDStringAppendObj(dsPtr, tmpObj);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
}
}
/*
* Now we do the standard processing of the stream we wrapped.
*/
if (getOptionProc) {
return getOptionProc(Tcl_GetChannelInstanceData(chanDataPtr->parent),
interp, optionName, dsPtr);
}
if (optionName == NULL) {
return TCL_OK;
}
if (chanDataPtr->format == TCL_ZLIB_FORMAT_GZIP) {
return Tcl_BadChannelOption(interp, optionName,
(chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE)
? gzipChanOptions : gunzipChanOptions);
} else {
return Tcl_BadChannelOption(interp, optionName,
(chanDataPtr->mode == TCL_ZLIB_STREAM_DEFLATE)
? compressChanOptions : decompressChanOptions);
}
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformWatch, ZlibTransformEventHandler --
*
* If we have data pending, trigger a readable event after a short time
* (in order to allow a real event to catch up).
*
*----------------------------------------------------------------------
*/
static void
ZlibTransformWatch(
void *instanceData,
int mask)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
Tcl_DriverWatchProc *watchProc;
/*
* This code is based on the code in tclIORTrans.c
*/
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(chanDataPtr->parent));
watchProc(Tcl_GetChannelInstanceData(chanDataPtr->parent), mask);
if (!(mask & TCL_READABLE) || !HaveFlag(chanDataPtr, STREAM_DECOMPRESS)) {
ZlibTransformEventTimerKill(chanDataPtr);
} else if (chanDataPtr->timer == NULL) {
chanDataPtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ZlibTransformTimerRun, chanDataPtr);
}
}
static int
ZlibTransformEventHandler(
void *instanceData,
int interestMask)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
ZlibTransformEventTimerKill(chanDataPtr);
return interestMask;
}
static inline void
ZlibTransformEventTimerKill(
ZlibChannelData *chanDataPtr)
{
if (chanDataPtr->timer != NULL) {
Tcl_DeleteTimerHandler(chanDataPtr->timer);
chanDataPtr->timer = NULL;
}
}
static void
ZlibTransformTimerRun(
void *clientData)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) clientData;
chanDataPtr->timer = NULL;
Tcl_NotifyChannel(chanDataPtr->chan, TCL_READABLE);
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformGetHandle --
*
* Anything that needs the OS handle is told to get it from what we are
* stacked on top of.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformGetHandle(
void *instanceData,
int direction,
void **handlePtr)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
return Tcl_GetChannelHandle(chanDataPtr->parent, direction, handlePtr);
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformBlockMode --
*
* We need to keep track of the blocking mode; it changes our behavior.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformBlockMode(
void *instanceData,
int mode)
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *) instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
chanDataPtr->flags |= ASYNC;
} else {
chanDataPtr->flags &= ~ASYNC;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3721 3722 3723 3724 3725 3726 3727 |
Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to
* use a default. Ignored if not compressing
* to produce gzip-format data. */
Tcl_Obj *compDictObj) /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
{
| > | | | | | | | | | | | | | | | | | | > | > | > | > | | > | | | | | | | > | > | > | | | | | > | | > | | | | > | | | | | | | | | | > | | | < | | | | > > > > | | | > | > | | | | 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 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 |
Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to
* use a default. Ignored if not compressing
* to produce gzip-format data. */
Tcl_Obj *compDictObj) /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
{
ZlibChannelData *chanDataPtr = (ZlibChannelData *)
Tcl_Alloc(sizeof(ZlibChannelData));
Tcl_Channel chan;
int wbits = 0;
if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) {
Tcl_Panic("unknown mode: %d", mode);
}
memset(chanDataPtr, 0, sizeof(ZlibChannelData));
chanDataPtr->mode = mode;
chanDataPtr->format = format;
chanDataPtr->readAheadLimit = limit;
if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) {
if (mode == TCL_ZLIB_STREAM_DEFLATE) {
if (gzipHeaderDictPtr) {
chanDataPtr->flags |= OUT_HEADER;
if (GenerateHeader(interp, gzipHeaderDictPtr,
&chanDataPtr->outHeader, NULL) != TCL_OK) {
goto error;
}
}
} else {
chanDataPtr->flags |= IN_HEADER;
chanDataPtr->inHeader.header.name = (Bytef *)
&chanDataPtr->inHeader.nativeFilenameBuf;
chanDataPtr->inHeader.header.name_max = MAXPATHLEN - 1;
chanDataPtr->inHeader.header.comment = (Bytef *)
&chanDataPtr->inHeader.nativeCommentBuf;
chanDataPtr->inHeader.header.comm_max = MAX_COMMENT_LEN - 1;
}
}
if (compDictObj != NULL) {
chanDataPtr->compDictObj = Tcl_DuplicateObj(compDictObj);
Tcl_IncrRefCount(chanDataPtr->compDictObj);
Tcl_GetBytesFromObj(NULL, chanDataPtr->compDictObj, (Tcl_Size *)NULL);
}
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_ZLIB:
wbits = WBITS_ZLIB;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
break;
case TCL_ZLIB_FORMAT_AUTO:
wbits = WBITS_AUTODETECT;
break;
default:
Tcl_Panic("bad format: %d", format);
}
/*
* Initialize input inflater or the output deflater.
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&chanDataPtr->inStream, wbits) != Z_OK) {
goto error;
}
chanDataPtr->inAllocated = DEFAULT_BUFFER_SIZE;
if (chanDataPtr->inAllocated < chanDataPtr->readAheadLimit) {
chanDataPtr->inAllocated = chanDataPtr->readAheadLimit;
}
chanDataPtr->inBuffer = (char *) Tcl_Alloc(chanDataPtr->inAllocated);
if (HaveFlag(chanDataPtr, IN_HEADER)) {
if (inflateGetHeader(&chanDataPtr->inStream,
&chanDataPtr->inHeader.header) != Z_OK) {
goto error;
}
}
if (chanDataPtr->format == TCL_ZLIB_FORMAT_RAW
&& chanDataPtr->compDictObj) {
if (SetInflateDictionary(&chanDataPtr->inStream,
chanDataPtr->compDictObj) != Z_OK) {
goto error;
}
}
} else {
if (deflateInit2(&chanDataPtr->outStream, level, Z_DEFLATED, wbits,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY) != Z_OK) {
goto error;
}
chanDataPtr->outAllocated = DEFAULT_BUFFER_SIZE;
chanDataPtr->outBuffer = (char *) Tcl_Alloc(chanDataPtr->outAllocated);
if (HaveFlag(chanDataPtr, OUT_HEADER)) {
if (deflateSetHeader(&chanDataPtr->outStream,
&chanDataPtr->outHeader.header) != Z_OK) {
goto error;
}
}
if (chanDataPtr->compDictObj) {
if (SetDeflateDictionary(&chanDataPtr->outStream,
chanDataPtr->compDictObj) != Z_OK) {
goto error;
}
}
}
chan = Tcl_StackChannel(interp, &zlibChannelType, chanDataPtr,
Tcl_GetChannelMode(channel), channel);
if (chan == NULL) {
goto error;
}
chanDataPtr->chan = chan;
chanDataPtr->parent = Tcl_GetStackedChannel(chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
Tcl_GetChannelName(chan), TCL_AUTO_LENGTH));
return chan;
error:
if (chanDataPtr->inBuffer) {
Tcl_Free(chanDataPtr->inBuffer);
inflateEnd(&chanDataPtr->inStream);
}
if (chanDataPtr->outBuffer) {
Tcl_Free(chanDataPtr->outBuffer);
deflateEnd(&chanDataPtr->outStream);
}
if (chanDataPtr->compDictObj) {
Tcl_DecrRefCount(chanDataPtr->compDictObj);
}
Tcl_Free(chanDataPtr);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ResultDecompress --
*
* Extract uncompressed bytes from the compression engine and store them
* in our buffer (buf) up to toRead bytes.
*
* Result:
* Number of bytes decompressed or -1 if error (with *errorCodePtr updated
* with reason).
*
* Side effects:
* After execution it updates chanDataPtr->inStream (next_in, avail_in) to
* reflect the data that has been decompressed.
*
*----------------------------------------------------------------------
*/
static int
ResultDecompress(
ZlibChannelData *chanDataPtr,
char *buf,
int toRead,
int flush,
int *errorCodePtr)
{
int e, written, resBytes = 0;
Tcl_Obj *errObj;
chanDataPtr->flags &= ~STREAM_DECOMPRESS;
chanDataPtr->inStream.next_out = (Bytef *) buf;
chanDataPtr->inStream.avail_out = toRead;
while (chanDataPtr->inStream.avail_out > 0) {
e = inflate(&chanDataPtr->inStream, flush);
/*
* Apply a compression dictionary if one is needed and we have one.
*/
if (e == Z_NEED_DICT && chanDataPtr->compDictObj) {
e = SetInflateDictionary(&chanDataPtr->inStream,
chanDataPtr->compDictObj);
if (e == Z_OK) {
/*
* A repetition of Z_NEED_DICT now is just an error.
*/
e = inflate(&chanDataPtr->inStream, flush);
}
}
/*
* avail_out is now the left over space in the output. Therefore
* "toRead - avail_out" is the amount of bytes generated.
*/
written = toRead - chanDataPtr->inStream.avail_out;
/*
* The cases where we're definitely done.
*/
if (e == Z_STREAM_END) {
chanDataPtr->flags |= STREAM_DONE;
resBytes += written;
break;
}
if (e == Z_OK) {
if (written == 0) {
break;
}
|
| ︙ | ︙ | |||
3930 3931 3932 3933 3934 3935 3936 | goto handleError; } /* * Check if the inflate stopped early. */ | | | > | | | > | | | | 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 |
goto handleError;
}
/*
* Check if the inflate stopped early.
*/
if (chanDataPtr->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) {
break;
}
}
if (!HaveFlag(chanDataPtr, STREAM_DONE)) {
/* if we have pending input data, but no available output buffer */
if (chanDataPtr->inStream.avail_in
&& !chanDataPtr->inStream.avail_out) {
/* next time try to decompress it got readable (new output buffer) */
chanDataPtr->flags |= STREAM_DECOMPRESS;
}
}
return resBytes;
handleError:
errObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj(
"-errorcode", TCL_AUTO_LENGTH));
Tcl_ListObjAppendElement(NULL, errObj,
ConvertErrorToList(e, chanDataPtr->inStream.adler));
Tcl_ListObjAppendElement(NULL, errObj,
Tcl_NewStringObj(chanDataPtr->inStream.msg, TCL_AUTO_LENGTH));
Tcl_SetChannelError(chanDataPtr->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
}
/*
*----------------------------------------------------------------------
* Finally, the TclZlibInit function. Used to install the zlib API.
|
| ︙ | ︙ | |||
3975 3976 3977 3978 3979 3980 3981 |
/*
* This does two things. It creates a counter used in the creation of
* stream commands, and it creates the namespace that will contain those
* commands.
*/
| | > | 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 |
/*
* This does two things. It creates a counter used in the creation of
* stream commands, and it creates the namespace that will contain those
* commands.
*/
Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}",
TCL_AUTO_LENGTH, 0);
/*
* Create the public scripted interface to this file's functionality.
*/
Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0);
|
| ︙ | ︙ | |||
4008 4009 4010 4011 4012 4013 4014 4015 |
/*
* Formally provide the package as a Tcl built-in.
*/
return Tcl_PkgProvideEx(interp, "tcl::zlib", TCL_ZLIB_VERSION, NULL);
}
/*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 |
/*
* Formally provide the package as a Tcl built-in.
*/
return Tcl_PkgProvideEx(interp, "tcl::zlib", TCL_ZLIB_VERSION, NULL);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to library/auto.tcl.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory # using a canonical searching algorithm. A side effect is to source the # initialization script and set a global library variable. # # Arguments: | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
# tcl_findLibrary --
#
# This is a utility for extensions that searches for a library directory
# using a canonical searching algorithm. A side effect is to source the
# initialization script and set a global library variable.
#
# Arguments:
# basename Prefix of the directory name, (e.g., "tk")
# version Version number of the package, (e.g., "8.0")
# patch Patchlevel of the package, (e.g., "8.0.3")
# initScript Initialization script to source (e.g., tk.tcl)
# enVarName environment variable to honor (e.g., TK_LIBRARY)
# varName Global variable to set when done (e.g., tk_library)
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
} elseif {[zipfs exists [file join $mountpoint $initScript]]} {
lappend dirs [file join $mountpoint $initScript]
set found 1
break
} else {
catch {zipfs unmount $mountpoint}
}
| | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
} elseif {[zipfs exists [file join $mountpoint $initScript]]} {
lappend dirs [file join $mountpoint $initScript]
set found 1
break
} else {
catch {zipfs unmount $mountpoint}
}
}
}
}
}
# 2. In the package script directory registered within the
# configuration of the package itself.
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
set error [catch {
set f [open $file]
fconfigure $f -encoding utf-8 -eofchar \x1A
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
| | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
set error [catch {
set f [open $file]
fconfigure $f -encoding utf-8 -eofchar \x1A
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source -encoding utf-8 \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 | # # This procedure allows extensions to register their own commands with the # auto_mkindex facility. For example, a package like [incr Tcl] might # register a "class" command so that class definitions could be added to a # "tclIndex" file for auto-loading. # # Arguments: | | | | | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 |
#
# This procedure allows extensions to register their own commands with the
# auto_mkindex facility. For example, a package like [incr Tcl] might
# register a "class" command so that class definitions could be added to a
# "tclIndex" file for auto-loading.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::command {name arglist body} {
hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}
# auto_mkindex_parser::commandInit --
#
# This does the actual work set up by auto_mkindex_parser::command. This is
# called when the interpreter used by the parser is created.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
if {$ns eq ""} {
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 |
# the file name that we know about (which will be a proper list, and so
# correctly quoted).
set name [string range [list \}[fullname $name]] 2 end]
set filenameParts [file split $scriptFile]
append index [format \
| | | 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
# the file name that we know about (which will be a proper list, and so
# correctly quoted).
set name [string range [list \}[fullname $name]] 2 end]
set filenameParts [file split $scriptFile]
append index [format \
{set auto_index(%s) [list source -encoding utf-8 [file join $dir %s]]%s} \
$name $filenameParts \n]
return
}
if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
|
| ︙ | ︙ |
Changes to library/clock.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | #---------------------------------------------------------------------- # # clock.tcl -- # # This file implements the portions of the [clock] ensemble that are # coded in Tcl. Refer to the users' manual to see the description of # the [clock] command and its subcommands. # # #---------------------------------------------------------------------- # # Copyright © 2004-2007 Kevin B. Kenny # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #---------------------------------------------------------------------- | > | < < | < < < < < < | | 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 |
#----------------------------------------------------------------------
#
# clock.tcl --
#
# This file implements the portions of the [clock] ensemble that are
# coded in Tcl. Refer to the users' manual to see the description of
# the [clock] command and its subcommands.
#
#
#----------------------------------------------------------------------
#
# Copyright © 2004-2007 Kevin B. Kenny
# Copyright © 2015 Sergey G. Brester aka sebres.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#----------------------------------------------------------------------
# msgcat 1.7 features are used.
package require msgcat 1.7
# Put the library directory into the namespace for the ensemble so that the
# library code can find message catalogs and time zone definition files.
namespace eval ::tcl::clock \
[list variable LibDir [info library]]
#----------------------------------------------------------------------
#
# clock --
#
# Manipulate times.
#
|
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
namespace export milliseconds
namespace export scan
namespace export seconds
namespace export add
# Import the message catalog commands that we use.
| < < | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
namespace export milliseconds
namespace export scan
namespace export seconds
namespace export add
# Import the message catalog commands that we use.
namespace import ::msgcat::mclocale
namespace import ::msgcat::mcpackagelocale
}
#----------------------------------------------------------------------
#
# ::tcl::clock::Initialize --
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
}
LOCALE_TIME_FORMAT {%H:%M:%S}
LOCALE_YEAR_FORMAT {%EC%Ey}
MONTHS_ABBREV {
Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
}
MONTHS_FULL {
| | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
}
LOCALE_TIME_FORMAT {%H:%M:%S}
LOCALE_YEAR_FORMAT {%EC%Ey}
MONTHS_ABBREV {
Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
}
MONTHS_FULL {
January February March
April May June
July August September
October November December
}
PM {pm}
TIME_FORMAT {%H:%M:%S}
TIME_FORMAT_12 {%I:%M:%S %P}
TIME_FORMAT_24 {%H:%M}
TIME_FORMAT_24_SECS {%H:%M:%S}
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
variable MINWIDE -9223372036854775808
variable MAXWIDE 9223372036854775807
# Day before Leap Day
variable FEB_28 58
# Translation table to map Windows TZI onto cities, so that the Olson
# rules can apply. In some cases the mapping is ambiguous, so it's wise
# to specify $::env(TCL_TZ) rather than simply depending on the system
# time zone.
# The keys are long lists of values obtained from the time zone
# information in the Registry. In order, the list elements are:
| > > > > > > > | | 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 |
variable MINWIDE -9223372036854775808
variable MAXWIDE 9223372036854775807
# Day before Leap Day
variable FEB_28 58
# Default configuration
::tcl::unsupported::clock::configure -current-locale [mclocale]
#::tcl::unsupported::clock::configure -default-locale C
#::tcl::unsupported::clock::configure -year-century 2000 \
# -century-switch 38
# Translation table to map Windows TZI onto cities, so that the Olson
# rules can apply. In some cases the mapping is ambiguous, so it's wise
# to specify $::env(TCL_TZ) rather than simply depending on the system
# time zone.
# The keys are long lists of values obtained from the time zone
# information in the Registry. In order, the list elements are:
# Bias StandardBias DaylightBias
# StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
# StandardDate.wDay StandardDate.wHour StandardDate.wMinute
# StandardDate.wSecond StandardDate.wMilliseconds
# DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
# DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
# DaylightDate.wSecond DaylightDate.wMilliseconds
# The values are the names of time zones where those rules apply. There
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 |
{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
{0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC
{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
| | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
{0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC
{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
:Africa/Cairo
{7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki
{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
{7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest
{7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens
{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
:Asia/Beirut
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 |
{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney
{39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea
{43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland
{43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji
{46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
}]
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney
{39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea
{43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland
{43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji
{46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
}]
# Legacy time zones, used primarily for parsing RFC822 dates.
variable LegacyTimeZone [dict create \
gmt +0000 \
ut +0000 \
utc +0000 \
bst +0100 \
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 557 558 559 560 561 562 563 | cdt -0500 \ mst -0700 \ mdt -0600 \ pst -0800 \ pdt -0700 \ yst -0900 \ ydt -0800 \ hst -1000 \ hdt -0900 \ cat -1000 \ ahst -1000 \ nt -1100 \ idlw -1200 \ cet +0100 \ | > > | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | cdt -0500 \ mst -0700 \ mdt -0600 \ pst -0800 \ pdt -0700 \ yst -0900 \ ydt -0800 \ akst -0900 \ akdt -0800 \ hst -1000 \ hdt -0900 \ cat -1000 \ ahst -1000 \ nt -1100 \ idlw -1200 \ cet +0100 \ |
| ︙ | ︙ | |||
619 620 621 622 623 624 625 |
x -1100 \
y -1200 \
z +0000 \
]
# Caches
| | | < < < < < < < < | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | < < < < < < < < < < < < < > | | > > | < < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < | < | < < < < < > > | < | > | < | | < | < < | < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < | < < < < | < | < < | < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < | < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < | | | < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | < < | | < < | < < < < | < < < < < < < < < < < < < < < < < | < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < < | < < | < < < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | | < < < < < < | < | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < | | < < < < < < < < < < < < < < < < < < < | < < | < < < < < | < < < > | < < < < < < < < < < | < < < < | < < < < < < < < | < < | < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < | | | < < < < < < < < < < | | < < < | < < < < | < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < | < < < < < < < < < < < < < < < < < < < < | < < < | < | < < < < | < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < | < < < < < < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < | | < | < < < < < | > | > | | > > > > > | | > > | > | > > | > > > | > > | < < > | < | 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 |
x -1100 \
y -1200 \
z +0000 \
]
# Caches
variable LocFmtMap [dict create]; # Dictionary with localized format maps
variable TimeZoneBad [dict create]; # Dictionary whose keys are time zone
# names and whose values are 1 if
# the time zone is unknown and 0
# if it is known.
variable TZData; # Array whose keys are time zone names
# and whose values are lists of quads
# comprising start time, UTC offset,
# Daylight Saving Time indicator, and
# time zone abbreviation.
variable mcLocales [dict create]; # Dictionary with loaded locales
variable mcMergedCat [dict create]; # Dictionary with merged locale catalogs
}
::tcl::clock::Initialize
#----------------------------------------------------------------------
# mcget --
#
# Return the merged translation catalog for the ::tcl::clock namespace
# Searching of catalog is similar to "msgcat::mc".
#
# Contrary to "msgcat::mc" may additionally load a package catalog
# on demand.
#
# Arguments:
# loc The locale used for translation.
#
# Results:
# Returns the dictionary object as whole catalog of the package/locale.
#
proc ::tcl::clock::mcget {loc} {
variable mcMergedCat
switch -- $loc system {
set loc [GetSystemLocale]
} current {
set loc [mclocale]
}
if {$loc ne {}} {
set loc [string tolower $loc]
}
# try to retrieve now if already available:
if {[dict exists $mcMergedCat $loc]} {
return [dict get $mcMergedCat $loc]
}
# get locales list for given locale (de_de -> {de_de de {}})
variable mcLocales
if {[dict exists $mcLocales $loc]} {
set loclist [dict get $mcLocales $loc]
} else {
# save current locale:
set prevloc [mclocale]
# lazy load catalog on demand (set it will load the catalog)
mcpackagelocale set $loc
set loclist [msgcat::mcutil::getpreferences $loc]
dict set $mcLocales $loc $loclist
# restore:
if {$prevloc ne $loc} {
mcpackagelocale set $prevloc
}
}
# get whole catalog:
mcMerge $loclist
}
# mcMerge --
#
# Merge message catalog dictionaries to one dictionary.
#
# Arguments:
# locales List of locales to merge.
#
# Results:
# Returns the (weak pointer) to merged dictionary of message catalog.
#
proc ::tcl::clock::mcMerge {locales} {
variable mcMergedCat
if {[dict exists $mcMergedCat [set loc [lindex $locales 0]]]} {
return [dict get $mcMergedCat $loc]
}
# package msgcat currently does not provide possibility to get whole catalog:
upvar ::msgcat::Msgs Msgs
set ns ::tcl::clock
# Merge sequential locales (in reverse order, e. g. {} -> en -> en_en):
if {[llength $locales] > 1} {
set mrgcat [mcMerge [lrange $locales 1 end]]
if {[dict exists $Msgs $ns $loc]} {
set mrgcat [dict merge $mrgcat [dict get $Msgs $ns $loc]]
dict set mrgcat L $loc
} else {
# be sure a duplicate is created, don't overwrite {} (common) locale:
set mrgcat [dict merge $mrgcat [dict create L $loc]]
}
} else {
if {[dict exists $Msgs $ns $loc]} {
set mrgcat [dict get $Msgs $ns $loc]
dict set mrgcat L $loc
} else {
# be sure a duplicate is created, don't overwrite {} (common) locale:
set mrgcat [dict create L $loc]
}
}
dict set mcMergedCat $loc $mrgcat
# return smart reference (shared dict as object with exact one ref-counter)
return $mrgcat
}
#----------------------------------------------------------------------
#
# GetSystemLocale --
#
# Determines the system locale, which corresponds to "system"
# keyword for locale parameter of 'clock' command.
#
# Parameters:
# None.
#
# Results:
# Returns the system locale.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc ::tcl::clock::GetSystemLocale {} {
if { $::tcl_platform(platform) ne {windows} } {
# On a non-windows platform, the 'system' locale is the same as
# the 'current' locale
return [mclocale]
}
# On a windows platform, the 'system' locale is adapted from the
# 'current' locale by applying the date and time formats from the
# Control Panel. First, load the 'current' locale if it's not yet
# loaded
mcpackagelocale set [mclocale]
# Make a new locale string for the system locale, and get the
# Control Panel information
set locale [mclocale]_windows
if { ! [mcpackagelocale present $locale] } {
LoadWindowsDateTimeFormats $locale
}
return $locale
}
#----------------------------------------------------------------------
#
# EnterLocale --
#
# Switch [mclocale] to a given locale if necessary
#
# Parameters:
# locale -- Desired locale
#
# Results:
# Returns the locale that was previously current.
#
# Side effects:
# Does [mclocale]. If necessary, loades the designated locale's files.
#
#----------------------------------------------------------------------
proc ::tcl::clock::EnterLocale { locale } {
switch -- $locale system {
set locale [GetSystemLocale]
} current {
set locale [mclocale]
}
# Select the locale, eventually load it
mcpackagelocale set $locale
return $locale
}
#----------------------------------------------------------------------
#
# _hasRegistry --
#
# Helper that checks whether registry module is available (Windows only)
# and loads it on demand.
#
#----------------------------------------------------------------------
proc ::tcl::clock::_hasRegistry {} {
set res 0
if { $::tcl_platform(platform) eq {windows} } {
if { [catch { package require registry 1.3 }] } {
# try to load registry directly from root (if uninstalled / development env):
if {[regexp {[/\\]library$} [info library]]} {catch {
load [lindex \
[glob -tails -directory [file dirname [info nameofexecutable]] \
tcl9registry*[expr {[::tcl::pkgconfig get debug] ? {g} : {}}].dll] 0 \
] Registry
}}
}
if { [namespace which -command ::registry] ne "" } {
set res 1
}
}
proc ::tcl::clock::_hasRegistry {} [list return $res]
return $res
}
#----------------------------------------------------------------------
#
# LoadWindowsDateTimeFormats --
#
# Load the date/time formats from the Control Panel in Windows and
|
| ︙ | ︙ | |||
2357 2358 2359 2360 2361 2362 2363 |
# default strings can be obtained if the Registry query fails.
#
#----------------------------------------------------------------------
proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
# Bail out if we can't find the Registry
| < | | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
# default strings can be obtained if the Registry query fails.
#
#----------------------------------------------------------------------
proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
# Bail out if we can't find the Registry
if { ![_hasRegistry] } return
if { ![catch {
registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
sShortDate
} string] } {
set quote {}
set datefmt {}
|
| ︙ | ︙ | |||
2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 | # # Map away locale-dependent format groups in a clock format. # # Parameters: # locale -- Current [mclocale] locale, supplied to avoid # an extra call # format -- Format supplied to [clock scan] or [clock format] # # Results: # Returns the string with locale-dependent composite format groups # substituted out. # # Side effects: # None. # #---------------------------------------------------------------------- | > > | > | < | | < | | | | | | | | | | < < < < < < < < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < | < < < < < < | < | < | < < | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < | < < | < | < < < < < < < < < < < < < < < < < < < | < < < < < < < < | < < | < | < | < | < < < < < | < < < < < < < < < < < < < < < < < < < < | < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | | < | | | | > | < | > | | < < | | < < < < < < < < < < < < < < < < < < < < | < < < < < < < | | > | > > | | | > | | 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 |
#
# Map away locale-dependent format groups in a clock format.
#
# Parameters:
# locale -- Current [mclocale] locale, supplied to avoid
# an extra call
# format -- Format supplied to [clock scan] or [clock format]
# mcd -- Message catalog dictionary for current locale (read-only,
# don't store it to avoid shared references).
#
# Results:
# Returns the string with locale-dependent composite format groups
# substituted out.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc ::tcl::clock::LocalizeFormat { locale format mcd } {
variable LocFmtMap
# get map list cached or build it:
if {[dict exists $LocFmtMap $locale]} {
set mlst [dict get $LocFmtMap $locale]
} else {
# Handle locale-dependent format groups by mapping them out of the format
# string. Note that the order of the [string map] operations is
# significant because later formats can refer to later ones; for example
# %c can refer to %X, which in turn can refer to %T.
set mlst {
%% %%
%D %m/%d/%Y
%+ {%a %b %e %H:%M:%S %Z %Y}
}
lappend mlst %EY [string map $mlst [dict get $mcd LOCALE_YEAR_FORMAT]]
lappend mlst %T [string map $mlst [dict get $mcd TIME_FORMAT_24_SECS]]
lappend mlst %R [string map $mlst [dict get $mcd TIME_FORMAT_24]]
lappend mlst %r [string map $mlst [dict get $mcd TIME_FORMAT_12]]
lappend mlst %X [string map $mlst [dict get $mcd TIME_FORMAT]]
lappend mlst %EX [string map $mlst [dict get $mcd LOCALE_TIME_FORMAT]]
lappend mlst %x [string map $mlst [dict get $mcd DATE_FORMAT]]
lappend mlst %Ex [string map $mlst [dict get $mcd LOCALE_DATE_FORMAT]]
lappend mlst %c [string map $mlst [dict get $mcd DATE_TIME_FORMAT]]
lappend mlst %Ec [string map $mlst [dict get $mcd LOCALE_DATE_TIME_FORMAT]]
dict set LocFmtMap $locale $mlst
}
# translate copy of format (don't use format object here, because otherwise
# it can lose its internal representation (string map - convert to unicode)
set locfmt [string map $mlst [string range " $format" 1 end]]
# Save original format as long as possible, because of internal
# representation (performance).
# Note that in this case such format will be never localized (also
# using another locales). To prevent this return a duplicate (but
# it may be slower).
if {$locfmt eq $format} {
set locfmt $format
}
return $locfmt
}
#----------------------------------------------------------------------
#
# GetSystemTimeZone --
#
# Determines the system time zone, which is the default for the
# 'clock' command if no other zone is supplied.
#
# Parameters:
# None.
#
# Results:
# Returns the system time zone.
#
# Side effects:
# Stores the system time zone in engine configuration, since
# determining it may be an expensive process.
#
#----------------------------------------------------------------------
proc ::tcl::clock::GetSystemTimeZone {} {
variable TimeZoneBad
if {[set result [getenv TCL_TZ]] ne {}} {
set timezone $result
} elseif {[set result [getenv TZ]] ne {}} {
set timezone $result
} else {
# ask engine for the cached timezone:
set timezone [::tcl::unsupported::clock::configure -system-tz]
if { $timezone ne "" } {
return $timezone
}
if { $::tcl_platform(platform) eq {windows} } {
set timezone [GuessWindowsTimeZone]
} elseif { [file exists /etc/localtime]
&& ![catch {ReadZoneinfoFile \
Tcl/Localtime /etc/localtime}] } {
set timezone :Tcl/Localtime
} else {
set timezone :localtime
}
}
if { ![dict exists $TimeZoneBad $timezone] } {
catch {set timezone [SetupTimeZone $timezone]}
}
if { [dict exists $TimeZoneBad $timezone] } {
set timezone :localtime
}
# tell backend - current system timezone:
::tcl::unsupported::clock::configure -system-tz $timezone
return $timezone
}
#----------------------------------------------------------------------
#
# SetupTimeZone --
#
# Given the name or specification of a time zone, sets up its in-memory
# data.
#
# Parameters:
# tzname - Name of a time zone
#
# Results:
# Unless the time zone is ':localtime', sets the TZData array to contain
# the lookup table for local<->UTC conversion. Returns an error if the
# time zone cannot be parsed.
#
#----------------------------------------------------------------------
proc ::tcl::clock::SetupTimeZone { timezone {alias {}} } {
variable TZData
if {! [info exists TZData($timezone)] } {
variable TimeZoneBad
if { [dict exists $TimeZoneBad $timezone] } {
return -code error \
-errorcode [list CLOCK badTimeZone $timezone] \
"time zone \"$timezone\" not found"
}
variable MINWIDE
if {
[regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
-> s hh mm ss]
} then {
# Make a fixed offset
::scan $hh %d hh
if { $mm eq {} } {
|
| ︙ | ︙ | |||
3101 3102 3103 3104 3105 3106 3107 |
# Convert using a time zone file
if {
[catch {
LoadTimeZoneFile [string range $timezone 1 end]
}] && [catch {
LoadZoneinfoFile [string range $timezone 1 end]
| | | > | | | > > > | < | > > > > | | > > > | > > > > > > > > > > > > > > > > > | | > | 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 |
# Convert using a time zone file
if {
[catch {
LoadTimeZoneFile [string range $timezone 1 end]
}] && [catch {
LoadZoneinfoFile [string range $timezone 1 end]
} ret opts]
} then {
dict unset opts -errorinfo
if {[lindex [dict get $opts -errorcode] 0] ne "CLOCK"} {
dict set opts -errorcode [list CLOCK badTimeZone $timezone]
set ret "time zone \"$timezone\" not found: $ret"
}
dict set TimeZoneBad $timezone 1
return -options $opts $ret
}
} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
# This looks like a POSIX time zone - try to process it
if { [catch {ProcessPosixTimeZone $tzfields} ret opts] } {
dict unset opts -errorinfo
if {[lindex [dict get $opts -errorcode] 0] ne "CLOCK"} {
dict set opts -errorcode [list CLOCK badTimeZone $timezone]
set ret "time zone \"$timezone\" not found: $ret"
}
dict set TimeZoneBad $timezone 1
return -options $opts $ret
} else {
set TZData($timezone) $ret
}
} else {
variable LegacyTimeZone
# We couldn't parse this as a POSIX time zone. Try again with a
# time zone file - this time without a colon
if { [catch { LoadTimeZoneFile $timezone }]
&& [catch { LoadZoneinfoFile $timezone } ret opts] } {
# Check may be a legacy zone:
if { $alias eq {} && ![catch {
set tzname [dict get $LegacyTimeZone [string tolower $timezone]]
}] } {
set tzname [::tcl::clock::SetupTimeZone $tzname $timezone]
set TZData($timezone) $TZData($tzname)
# tell backend - timezone is initialized and return shared timezone object:
return [::tcl::unsupported::clock::configure -setup-tz $timezone]
}
dict unset opts -errorinfo
if {[lindex [dict get $opts -errorcode] 0] ne "CLOCK"} {
dict set opts -errorcode [list CLOCK badTimeZone $timezone]
set ret "time zone \"$timezone\" not found: $ret"
}
dict set TimeZoneBad $timezone 1
return -options $opts $ret
}
set TZData($timezone) $TZData(:$timezone)
}
}
# tell backend - timezone is initialized and return shared timezone object:
::tcl::unsupported::clock::configure -setup-tz $timezone
}
#----------------------------------------------------------------------
#
# GuessWindowsTimeZone --
#
# Determines the system time zone on windows.
|
| ︙ | ︙ | |||
3162 3163 3164 3165 3166 3167 3168 |
# zone that uses the same rules. If it finds one, it returns it; otherwise,
# it constructs a Posix-style time zone string and returns that.
#
#----------------------------------------------------------------------
proc ::tcl::clock::GuessWindowsTimeZone {} {
variable WinZoneInfo
| < | | 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 |
# zone that uses the same rules. If it finds one, it returns it; otherwise,
# it constructs a Posix-style time zone string and returns that.
#
#----------------------------------------------------------------------
proc ::tcl::clock::GuessWindowsTimeZone {} {
variable WinZoneInfo
variable TimeZoneBad
if { ![_hasRegistry] } {
return :localtime
}
# Dredge time zone information out of the registry
if { [catch {
set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
|
| ︙ | ︙ | |||
3203 3204 3205 3206 3207 3208 3209 |
# Make up a Posix time zone specifier if we can't find one. Check here
# that the tzdata file exists, in case we're running in an environment
# (e.g. starpack) where tzdata is incomplete. (Bug 1237907)
if { [dict exists $WinZoneInfo $data] } {
set tzname [dict get $WinZoneInfo $data]
if { ! [dict exists $TimeZoneBad $tzname] } {
| | | | 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 |
# Make up a Posix time zone specifier if we can't find one. Check here
# that the tzdata file exists, in case we're running in an environment
# (e.g. starpack) where tzdata is incomplete. (Bug 1237907)
if { [dict exists $WinZoneInfo $data] } {
set tzname [dict get $WinZoneInfo $data]
if { ! [dict exists $TimeZoneBad $tzname] } {
catch {set tzname [SetupTimeZone $tzname]}
}
} else {
set tzname {}
}
if { $tzname eq {} || [dict exists $TimeZoneBad $tzname] } {
lassign $data \
bias stdBias dstBias \
stdYear stdMonth stdDayOfWeek stdDayOfMonth \
stdHour stdMinute stdSecond stdMillisec \
dstYear dstMonth dstDayOfWeek dstDayOfMonth \
dstHour dstMinute dstSecond dstMillisec
set stdDelta [expr { $bias + $stdBias }]
|
| ︙ | ︙ | |||
3306 3307 3308 3309 3310 3311 3312 |
return
}
# Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
| | | | 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 |
return
}
# Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
if { [regexp {^[/\\]|^[a-zA-Z]+:|(?:^|[/\\])\.\.} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone :$fileName] \
"time zone \":$fileName\" not valid"
}
try {
source [file join $DataDir $fileName]
} on error {} {
return -code error \
-errorcode [list CLOCK badTimeZone :$fileName] \
|
| ︙ | ︙ | |||
3346 3347 3348 3349 3350 3351 3352 |
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
variable ZoneinfoPaths
# Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
| | | > | > > > > > | 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 |
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
variable ZoneinfoPaths
# Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
if { [regexp {^[/\\]|^[a-zA-Z]+:|(?:^|[/\\])\.\.} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone :$fileName] \
"time zone \":$fileName\" not valid"
}
set fname ""
foreach d $ZoneinfoPaths {
set fname [file join $d $fileName]
if { [file readable $fname] && [file isfile $fname] } {
break
}
set fname ""
}
if {$fname eq ""} {
return -code error \
-errorcode [list CLOCK badTimeZone :$fileName] \
"time zone \":$fileName\" not found"
}
ReadZoneinfoFile $fileName $fname
}
#----------------------------------------------------------------------
#
# ReadZoneinfoFile --
|
| ︙ | ︙ | |||
3879 3880 3881 3882 3883 3884 3885 |
proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
variable FEB_28
# Determine the start or end day of DST
| | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 |
proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
variable FEB_28
# Determine the start or end day of DST
set date [dict create era CE year $y gregorian 1]
set doy [dict get $z ${bound}DayOfYear]
if { $doy ne {} } {
# Time was specified as a day of the year
if { [dict get $z ${bound}J] ne {}
&& [IsGregorianLeapYear $date]
&& ( $doy > $FEB_28 ) } {
incr doy
}
dict set date dayOfYear $doy
set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
} else {
# Time was specified as a day of the week within a month
|
| ︙ | ︙ | |||
3933 3934 3935 3936 3937 3938 3939 |
} else {
set s [lindex [::scan $s %d] 0]
}
set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
return [expr { $seconds + $tod }]
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 |
} else {
set s [lindex [::scan $s %d] 0]
}
set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
return [expr { $seconds + $tod }]
}
#----------------------------------------------------------------------
#
# GetJulianDayFromEraYearDay --
#
# Given a year, month and day on the Gregorian calendar, determines
# the Julian Day Number beginning at noon on that date.
#
|
| ︙ | ︙ | |||
4149 4150 4151 4152 4153 4154 4155 |
proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
set k [expr { ( $weekday + 6 ) % 7 }]
return [expr { $j - ( $j - $k ) % 7 }]
}
#----------------------------------------------------------------------
#
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < | | > | < | < > | | < < | < | 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 |
proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
set k [expr { ( $weekday + 6 ) % 7 }]
return [expr { $j - ( $j - $k ) % 7 }]
}
#----------------------------------------------------------------------
#
# ChangeCurrentLocale --
#
# The global locale was changed within msgcat.
# Clears the buffered parse functions of the current locale.
#
# Parameters:
# loclist (ignored)
#
# Results:
# None.
#
# Side effects:
# Buffered parse functions are cleared.
#
#----------------------------------------------------------------------
proc ::tcl::clock::ChangeCurrentLocale {args} {
::tcl::unsupported::clock::configure -current-locale [lindex $args 0]
}
#----------------------------------------------------------------------
#
# ClearCaches --
#
# Clears all caches to reclaim the memory used in [clock]
#
# Parameters:
# None.
#
# Results:
# None.
#
# Side effects:
# Caches are cleared.
#
#----------------------------------------------------------------------
proc ::tcl::clock::ClearCaches {} {
variable LocFmtMap
variable mcMergedCat
variable TimeZoneBad
# tell backend - should invalidate:
::tcl::unsupported::clock::configure -clear
# clear msgcat cache:
set mcMergedCat [dict create]
set LocFmtMap {}
set TimeZoneBad {}
InitTZData
}
|
Added library/encoding/koi8-ru.enc.
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Encoding file: koi8-ru, single-byte S 003F 0 1 00 0000000100020003000400050006000700080009000A000B000C000D000E000F 0010001100120013001400150016001700180019001A001B001C001D001E001F 0020002100220023002400250026002700280029002A002B002C002D002E002F 0030003100320033003400350036003700380039003A003B003C003D003E003F 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 25002502250C251025142518251C2524252C2534253C258025842588258C2590 259125922593232025A02219221A22482264226500A0232100B000B200B700F7 25502551255204510454255404560457255725582559255A255B0491045E255E 255F25602561040104042563040604072566256725682569256A0490040E00A9 044E0430043104460434043504440433044504380439043A043B043C043D043E 043F044F044004410442044304360432044C044B04370448044D04490447044A 042E0410041104260414041504240413042504180419041A041B041C041D041E 041F042F042004210422042304160412042C042B04170428042D04290427042A |
Added library/encoding/koi8-t.enc.
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Encoding file: koi8-t, single-byte S 003F 0 1 00 0000000100020003000400050006000700080009000A000B000C000D000E000F 0010001100120013001400150016001700180019001A001B001C001D001E001F 0020002100220023002400250026002700280029002A002B002C002D002E002F 0030003100320033003400350036003700380039003A003B003C003D003E003F 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 049B0493201A0492201E2026202020210000203004B3203904B204B704B60000 049A20182019201C201D202220132014000021220000203A0000000000000000 000004EF04EE045100A404E300A600A700000000000000AB00AC00AD00AE0000 00B000B100B20401000004E200B600B700002116000000BB00000000000000A9 044E0430043104460434043504440433044504380439043A043B043C043D043E 043F044F044004410442044304360432044C044B04370448044D04490447044A 042E0410041104260414041504240413042504180419041A041B041C041D041E 041F042F042004210422042304160412042C042B04170428042D04290427042A |
Changes to library/encoding/koi8-u.enc.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 25002502250C251025142518251C2524252C2534253C258025842588258C2590 259125922593232025A02219221A22482264226500A0232100B000B200B700F7 25502551255204510454255404560457255725582559255A255B0491255D255E | | | 9 10 11 12 13 14 15 16 17 18 19 20 | 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 25002502250C251025142518251C2524252C2534253C258025842588258C2590 259125922593232025A02219221A22482264226500A0232100B000B200B700F7 25502551255204510454255404560457255725582559255A255B0491255D255E 255F25602561040104042563040604072566256725682569256A0490256C00A9 044E0430043104460434043504440433044504380439043A043B043C043D043E 043F044F044004410442044304360432044C044B04370448044D04490447044A 042E0410041104260414041504240413042504180419041A041B041C041D041E 041F042F042004210422042304160412042C042B04170428042D04290427042A |
Changes to library/history.tcl.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | # Add an item to the history, and optionally eval it at the global scope # # Parameters: # event the command to add # exec (optional) a substring of "exec" causes the command to # be evaled. # Results: | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
# Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
# event the command to add
# exec (optional) a substring of "exec" causes the command to
# be evaled.
# Results:
# If executing, then the results of the command are returned
#
# Side Effects:
# Adds to the history list
proc ::tcl::HistAdd {event {exec {}}} {
variable history
|
| ︙ | ︙ | |||
193 194 195 196 197 198 199 |
set result {}
set newline ""
for {set i [expr {$history(nextid) - $count + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
| | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
set result {}
set newline ""
for {set i [expr {$history(nextid) - $count + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
append result $newline[format "%6d %s" $i $cmd]
set newline \n
}
return $result
}
# tcl::HistRedo --
|
| ︙ | ︙ |
Changes to library/http/http.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # http.tcl -- # # Client-side HTTP for GET, POST, and HEAD commands. These routines can # be used in untrusted code that uses the Safesock security policy. # These procedures use a callback interface to avoid using vwait, which # is not defined in the safe base. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands. These routines can
# be used in untrusted code that uses the Safesock security policy.
# These procedures use a callback interface to avoid using vwait, which
# is not defined in the safe base.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.10.0
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
)?
}
variable TmpSockCounter 0
variable ThreadCounter 0
variable reasonDict [dict create {*}{
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
)?
}
variable TmpSockCounter 0
variable ThreadCounter 0
variable reasonDict [dict create {*}{
100 Continue
101 {Switching Protocols}
102 Processing
103 {Early Hints}
200 OK
201 Created
202 Accepted
203 {Non-Authoritative Information}
204 {No Content}
205 {Reset Content}
206 {Partial Content}
207 Multi-Status
208 {Already Reported}
226 {IM Used}
300 {Multiple Choices}
301 {Moved Permanently}
302 Found
303 {See Other}
304 {Not Modified}
305 {Use Proxy}
306 (Unused)
307 {Temporary Redirect}
308 {Permanent Redirect}
400 {Bad Request}
401 Unauthorized
402 {Payment Required}
403 Forbidden
404 {Not Found}
405 {Method Not Allowed}
406 {Not Acceptable}
407 {Proxy Authentication Required}
408 {Request Timeout}
409 Conflict
410 Gone
411 {Length Required}
412 {Precondition Failed}
413 {Content Too Large}
414 {URI Too Long}
415 {Unsupported Media Type}
416 {Range Not Satisfiable}
417 {Expectation Failed}
418 (Unused)
421 {Misdirected Request}
422 {Unprocessable Content}
423 Locked
424 {Failed Dependency}
425 {Too Early}
426 {Upgrade Required}
428 {Precondition Required}
429 {Too Many Requests}
431 {Request Header Fields Too Large}
451 {Unavailable For Legal Reasons}
500 {Internal Server Error}
501 {Not Implemented}
502 {Bad Gateway}
503 {Service Unavailable}
504 {Gateway Timeout}
505 {HTTP Version Not Supported}
506 {Variant Also Negotiates}
507 {Insufficient Storage}
508 {Loop Detected}
510 {Not Extended (OBSOLETED)}
511 {Network Authentication Required}
}]
variable failedProxyValues {
binary
body
charset
coding
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 |
# list of port, command, variable name, (boolean) threadability,
# and (boolean) endToEndProxy that was registered.
proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} {
variable urlTypes
set lower [string tolower $proto]
if {[info exists urlTypes($lower)]} {
| | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
# list of port, command, variable name, (boolean) threadability,
# and (boolean) endToEndProxy that was registered.
proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} {
variable urlTypes
set lower [string tolower $proto]
if {[info exists urlTypes($lower)]} {
unregister $lower
}
set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy]
# If the external handler for protocol $proto has given $socketCmdVarName the expected
# value "::socket", overwrite it with the new value.
if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::socket})} {
set $socketCmdVarName ::http::socketAsCallback
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 | # http::config -- # # See documentation for details. # # Arguments: # args Options parsed by the procedure. # Results: | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
# http::config --
#
# See documentation for details.
#
# Arguments:
# args Options parsed by the procedure.
# Results:
# TODO
proc http::config {args} {
variable http
set options [lsort [array names http -*]]
set usage [join $options ", "]
if {[llength $args] == 0} {
set result {}
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
#
# Return Value: the reason phrase
# ------------------------------------------------------------------------------
proc http::reasonPhrase {code} {
variable reasonDict
if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
| | | | | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 |
#
# Return Value: the reason phrase
# ------------------------------------------------------------------------------
proc http::reasonPhrase {code} {
variable reasonDict
if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
set msg {argument must be a three-digit integer from 100 to 599}
return -code error $msg
}
if {[dict exists $reasonDict $code]} {
set reason [dict get $reasonDict $code]
} else {
set reason Unassigned
}
return $reason
}
# http::Finish --
#
# Clean up the socket and eval close time callbacks
#
# Arguments:
# token Connection token.
# errormsg (optional) If set, forces status to error.
# skipCB (optional) If set, don't call the -command callback. This
# is useful when geturl wants to throw an exception instead
# of calling the callback. That way, the same error isn't
# reported to two places.
#
# Side Effects:
# May close the socket.
proc http::Finish {token {errormsg ""} {skipCB 0}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
|
| ︙ | ︙ | |||
450 451 452 453 454 455 456 |
if {[info commands ${token}--EventCoroutine] ne {}} {
rename ${token}--EventCoroutine {}
}
if {[info commands ${token}--SocketCoroutine] ne {}} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(socketcoro)]} {
| | | | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
if {[info commands ${token}--EventCoroutine] ne {}} {
rename ${token}--EventCoroutine {}
}
if {[info commands ${token}--SocketCoroutine] ne {}} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(socketcoro)]} {
Log $token Cancel socket after-idle event (Finish)
after cancel $state(socketcoro)
unset state(socketcoro)
}
# Is this an upgrade request/response?
set upgradeResponse \
[expr { [info exists state(upgradeRequest)]
&& $state(upgradeRequest)
&& [info exists state(http)]
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
} {
set closeQueue 1
set connId $state(socketinfo)
if {[info exists state(sock)]} {
set sock $state(sock)
CloseSocket $state(sock) $token
} else {
| | | | | | | < | | | | | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
} {
set closeQueue 1
set connId $state(socketinfo)
if {[info exists state(sock)]} {
set sock $state(sock)
CloseSocket $state(sock) $token
} else {
# When opening the socket and calling http::reset
# immediately, the socket may not yet exist.
# Test http-4.11 may come here.
}
if {$state(tid) ne {}} {
# When opening the socket in a thread, and calling http::reset
# immediately, the thread may still exist.
# Test http-4.11 may come here.
thread::release $state(tid)
set state(tid) {}
} else {
}
} elseif {$upgradeResponse} {
# Special handling for an upgrade request/response.
# - geturl ensures that this is not a "persistent" socket used for
# multiple HTTP requests, so a call to KeepSocket is not needed.
# - Leave socket open, so a call to CloseSocket is not needed either.
# - Remove fileevent bindings. The caller will set its own bindings.
# - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND
# PASSED TO http::geturl AS -command callback.
catch {fileevent $state(sock) readable {}}
catch {fileevent $state(sock) writable {}}
} elseif {([info exists state(-keepalive)] && !$state(-keepalive))
|| ([info exists state(connection)] && ("close" in $state(connection)))
} {
set closeQueue 1
set connId $state(socketinfo)
if {[info exists state(sock)]} {
set sock $state(sock)
CloseSocket $state(sock) $token
} else {
# When opening the socket and calling http::reset
# immediately, the socket may not yet exist.
# Test http-4.11 may come here.
}
} elseif {
([info exists state(-keepalive)] && $state(-keepalive))
&& ([info exists state(connection)] && ("close" ni $state(connection)))
} {
KeepSocket $token
}
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 | # See documentation for details. # # Arguments: # token Connection token. # why Status info. # # Side Effects: | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
# See documentation for details.
#
# Arguments:
# token Connection token.
# why Status info.
#
# Side Effects:
# See Finish
proc http::reset {token {why reset}} {
variable $token
upvar 0 $token state
set state(status) $why
catch {fileevent $state(sock) readable {}}
catch {fileevent $state(sock) writable {}}
|
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 |
set usage [join [lsort $options] ", "]
set options [string map {- ""} $options]
set pat ^-(?:[join $options |])$
foreach {flag value} $args {
if {[regexp -- $pat $flag]} {
# Validate numbers
if { [info exists type($flag)]
| | | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 |
set usage [join [lsort $options] ", "]
set options [string map {- ""} $options]
set pat ^-(?:[join $options |])$
foreach {flag value} $args {
if {[regexp -- $pat $flag]} {
# Validate numbers
if { [info exists type($flag)]
&& (![string is $type($flag) -strict $value])
} {
unset $token
return -code error \
"Bad value for $flag ($value), must be $type($flag)"
}
if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
unset $token
|
| ︙ | ︙ | |||
1400 1401 1402 1403 1404 1405 1406 |
# Pass -myaddr directly to the socket command
if {[info exists state(-myaddr)]} {
lappend sockopts -myaddr $state(-myaddr)
}
if {$useSockThread} {
| | | | 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 |
# Pass -myaddr directly to the socket command
if {[info exists state(-myaddr)]} {
lappend sockopts -myaddr $state(-myaddr)
}
if {$useSockThread} {
set targs [list -type $token]
} else {
set targs {}
}
set state(connArgs) [list $proto $phost $srvurl]
set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr]
# See if we are supposed to use a previously opened channel.
# - In principle, ANY call to http::geturl could use a previously opened
# channel if it is available - the "Connection: keep-alive" header is a
|
| ︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 |
}
}
set state(reusing) $reusing
unset reusing
if {![info exists sock]} {
| | | | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 |
}
}
set state(reusing) $reusing
unset reusing
if {![info exists sock]} {
# N.B. At this point ([info exists sock] == $state(reusing)).
# This will no longer be true after we set a value of sock here.
# Give the socket a placeholder name.
set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
}
set state(sock) $sock
if {$state(reusing)} {
# Define these for use (only) by http::ReplayIfDead if the persistent
|
| ︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 |
if { $state(-keepalive)
&& (![info exists socketMapping($state(socketinfo))])
} {
# This code is executed only for the first -keepalive request on a
# socket. It makes the socket persistent.
##Log " PreparePersistentConnection" $token -- $sock -- DO
| | | | | | | | | | | | | | | | | | | | | | | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 |
if { $state(-keepalive)
&& (![info exists socketMapping($state(socketinfo))])
} {
# This code is executed only for the first -keepalive request on a
# socket. It makes the socket persistent.
##Log " PreparePersistentConnection" $token -- $sock -- DO
set DoLater [PreparePersistentConnection $token]
} else {
##Log " PreparePersistentConnection" $token -- $sock -- SKIP
set DoLater {-traceread 0 -tracewrite 0}
}
if {$state(ReusingPlaceholder)} {
# - This request was added to the socketPhQueue of a persistent
# connection.
# - But the connection has not yet been created and is a placeholder;
# - And the placeholder was created by an earlier request.
# - When that earlier request calls OpenSocket, its placeholder is
# replaced with a true socket, and it then executes the equivalent of
# OpenSocket for any subsequent requests that have
# $state(ReusingPlaceholder).
Log >J$tk after idle coro NO - ReusingPlaceholder
} elseif {$state(alreadyQueued)} {
# - This request was added to the socketWrQueue and socketPlayCmd
# of a persistent connection that will close at the end of its current
# read operation.
Log >J$tk after idle coro NO - alreadyQueued
} else {
Log >J$tk after idle coro YES
set CoroName ${token}--SocketCoroutine
set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
$token $DoLater]]
dict set socketCoEvent($state(socketinfo)) $token $cancel
set state(socketcoro) $cancel
}
return
}
# ------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1673 1674 1675 1676 1677 1678 1679 |
set socketProxyId($state(socketinfo)) $state(proxyUsed)
# - The value of state(proxyUsed) was set in http::CreateToken to either
# "none" or "HttpProxy".
# - $token is the first transaction to use this placeholder, so there are
# no other tokens whose (proxyUsed) must be modified.
if {![info exists socketRdState($state(socketinfo))]} {
| | | | | | | | | | | | | | | | | | | | | | 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 |
set socketProxyId($state(socketinfo)) $state(proxyUsed)
# - The value of state(proxyUsed) was set in http::CreateToken to either
# "none" or "HttpProxy".
# - $token is the first transaction to use this placeholder, so there are
# no other tokens whose (proxyUsed) must be modified.
if {![info exists socketRdState($state(socketinfo))]} {
set socketRdState($state(socketinfo)) {}
# set varName ::http::socketRdState($state(socketinfo))
# trace add variable $varName unset ::http::CancelReadPipeline
dict set DoLater -traceread 1
}
if {![info exists socketWrState($state(socketinfo))]} {
set socketWrState($state(socketinfo)) {}
# set varName ::http::socketWrState($state(socketinfo))
# trace add variable $varName unset ::http::CancelWritePipeline
dict set DoLater -tracewrite 1
}
if {$state(-pipeline)} {
#Log new, init for pipelined, GRANT write access to $token in geturl
# Also grant premature read access to the socket. This is OK.
set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
} else {
# socketWrState is not used by this non-pipelined transaction.
# We cannot leave it as "Wready" because the next call to
# http::geturl with a pipelined transaction would conclude that the
# socket is available for writing.
#Log new, init for nonpipeline, GRANT r/w access to $token in geturl
set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
}
# Value of socketPhQueue() may have already been set by ReplayCore.
if {![info exists socketPhQueue($state(sock))]} {
set socketPhQueue($state(sock)) {}
}
set socketRdQueue($state(socketinfo)) {}
set socketWrQueue($state(socketinfo)) {}
set socketClosing($state(socketinfo)) 0
set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
set socketCoEvent($state(socketinfo)) {}
set socketProxyId($state(socketinfo)) {}
|
| ︙ | ︙ | |||
1747 1748 1749 1750 1751 1752 1753 |
variable socketPlayCmd
variable socketCoEvent
variable socketProxyId
Log >K$tk Start OpenSocket coroutine
if {![info exists state(-keepalive)]} {
| | | | | | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 |
variable socketPlayCmd
variable socketCoEvent
variable socketProxyId
Log >K$tk Start OpenSocket coroutine
if {![info exists state(-keepalive)]} {
# The request has already been cancelled by the calling script.
return
}
set sockOld $state(sock)
dict unset socketCoEvent($state(socketinfo)) $token
unset -nocomplain state(socketcoro)
if {[catch {
if {$state(reusing)} {
# If ($state(reusing)) is true, then we do not need to create a new
# socket, even if $sockOld is only a placeholder for a socket.
set sock $sockOld
} else {
# set sock in the [catch] below.
set pre [clock milliseconds]
##Log pre socket opened, - token $token
##Log $state(openCmd) - token $token
set sock [namespace eval :: $state(openCmd)]
set state(sock) $sock
# Normal return from $state(openCmd) always returns a valid socket.
|
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 |
}
fconfigure $sock -translation {auto crlf} \
-buffersize $state(-blocksize)
if {[package vsatisfies [package provide Tcl] 9.0-]} {
fconfigure $sock -profile replace
}
##Log socket opened, DONE fconfigure - token $token
| | | | | | | | 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 |
}
fconfigure $sock -translation {auto crlf} \
-buffersize $state(-blocksize)
if {[package vsatisfies [package provide Tcl] 9.0-]} {
fconfigure $sock -profile replace
}
##Log socket opened, DONE fconfigure - token $token
}
Log "Using $sock for $state(socketinfo) - token $token" \
[expr {$state(-keepalive)?"keepalive":""}]
# Code above has set state(sock) $sock
ConfigureNewSocket $token $sockOld $DoLater
##Log OpenSocket success $sock - token $token
} result errdict]} {
##Log OpenSocket failed $result - token $token
# There may be other requests in the socketPhQueue.
# Prepare socketPlayCmd so that Finish will replay them.
if { ($state(-keepalive)) && (!$state(reusing))
&& [info exists socketPhQueue($sockOld)]
&& ($socketPhQueue($sockOld) ne {})
} {
if {$socketMapping($state(socketinfo)) ne $sockOld} {
Log "WARNING: this code should not be reached.\
{$socketMapping($state(socketinfo)) ne $sockOld}"
}
set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)]
set socketPhQueue($sockOld) {}
}
if {[string range $result 0 20] eq {proxy connect failed:}} {
# - The HTTPS proxy did not create a socket. The pre-existing value
# (a "placeholder socket") is unchanged.
# - The proxy returned a valid HTTP response to the failed CONNECT
# request, and http::SecureProxyConnect copied this to $token,
# and also set ${token}(connection) set to "close".
# - Remove the error message $result so that Finish delivers this
# HTTP response to the caller.
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 |
set reusing $state(reusing)
set sock $state(sock)
set proxyUsed $state(proxyUsed)
##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed
if {(!$reusing) && ($sock ne $sockOld)} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 |
set reusing $state(reusing)
set sock $state(sock)
set proxyUsed $state(proxyUsed)
##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed
if {(!$reusing) && ($sock ne $sockOld)} {
# Replace the placeholder value sockOld with sock.
if { [info exists socketMapping($state(socketinfo))]
&& ($socketMapping($state(socketinfo)) eq $sockOld)
} {
set socketMapping($state(socketinfo)) $sock
set socketProxyId($state(socketinfo)) $proxyUsed
# tokens that use the placeholder $sockOld are updated below.
##Log set socketMapping($state(socketinfo)) $sock
}
# Now finish any tasks left over from PreparePersistentConnection on
# the connection.
#
# The "unset" traces are fired by init (clears entire arrays), and
# by http::Unset.
# Unset is called by CloseQueuedQueries and (possibly never) by geturl.
#
# CancelReadPipeline, CancelWritePipeline call http::Finish for each
# token.
#
# FIXME If Finish is placeholder-aware, these traces can be set earlier,
# in PreparePersistentConnection.
if {[dict get $DoLater -traceread]} {
set varName ::http::socketRdState($state(socketinfo))
trace add variable $varName unset ::http::CancelReadPipeline
}
if {[dict get $DoLater -tracewrite]} {
set varName ::http::socketWrState($state(socketinfo))
trace add variable $varName unset ::http::CancelWritePipeline
}
}
# Do this in all cases.
ScheduleRequest $token
# Now look at all other tokens that use the placeholder $sockOld.
if { (!$reusing)
&& ($sock ne $sockOld)
&& [info exists socketPhQueue($sockOld)]
} {
##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
foreach tok $socketPhQueue($sockOld) {
# 1. Amend the token's (sock).
##Log set ${tok}(sock) $sock
set ${tok}(sock) $sock
set ${tok}(proxyUsed) $proxyUsed
# 2. Schedule the token's HTTP request.
# Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0.
|
| ︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 |
# pipelined request jumping the queue.
##Log "HTTP request for token $token is queued for nonpipeline use"
#Log re-use nonpipeline, GRANT delayed write access to $token in geturl
set socketWrState($state(socketinfo)) peNding
lappend socketWrQueue($state(socketinfo)) $token
} else {
| | | | | | | | | | | 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 |
# pipelined request jumping the queue.
##Log "HTTP request for token $token is queued for nonpipeline use"
#Log re-use nonpipeline, GRANT delayed write access to $token in geturl
set socketWrState($state(socketinfo)) peNding
lappend socketWrQueue($state(socketinfo)) $token
} else {
if {$reusing && $state(-pipeline)} {
#Log new, init for pipelined, GRANT write access to $token in geturl
# DO NOT grant premature read access to the socket.
# set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
} elseif {$reusing} {
# socketWrState is not used by this non-pipelined transaction.
# We cannot leave it as "Wready" because the next call to
# http::geturl with a pipelined transaction would conclude that the
# socket is available for writing.
#Log new, init for nonpipeline, GRANT r/w access to $token in geturl
set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
} else {
}
# Process the request now.
# - Command is not called unless $state(sock) is a real socket handle
# and not a placeholder.
# - All (!$reusing) cases come here.
# - Some $reusing cases come here too if the connection is
# marked as ready. Those $reusing cases are:
# $reusing && ($socketWrState($state(socketinfo)) eq "Wready") &&
# EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready")
# OR $pipeline
#
#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token
# Connect does its own fconfigure.
lassign $state(connArgs) proto phost srvurl
if {[catch {
fileevent $state(sock) writable \
[list http::Connect $token $proto $phost $srvurl]
} res opts]} {
# The socket no longer exists.
##Log bug -- socket gone -- $res -- $opts
|
| ︙ | ︙ | |||
2280 2281 2282 2283 2284 2285 2286 | # Some server implementations of HTTP/1.0 have a faulty # implementation of RFC 2068 Keep-Alive. # Don't leave this to chance. # For HTTP/1.0 we have already "set state(connection) close" # and "state(-keepalive) 0". set ConnVal close } | | | | | | 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 |
# Some server implementations of HTTP/1.0 have a faulty
# implementation of RFC 2068 Keep-Alive.
# Don't leave this to chance.
# For HTTP/1.0 we have already "set state(connection) close"
# and "state(-keepalive) 0".
set ConnVal close
}
# Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
# Pat Thoyts).
if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
SendHeader $token Proxy-Authorization $http(-proxyauth)
}
# RFC7230 A.1 - "clients are encouraged not to send the
# Proxy-Connection header field in any requests"
set accept_encoding_seen 0
set content_type_seen 0
set connection_seen 0
foreach {key value} $state(-headers) {
set value [string map [list \n "" \r ""] $value]
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 |
set content_type_seen 1
}
if {[string equal -nocase $key "content-length"]} {
set contDone 1
set state(querylength) $value
}
if { [string equal -nocase $key "connection"]
| | | 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 |
set content_type_seen 1
}
if {[string equal -nocase $key "content-length"]} {
set contDone 1
set state(querylength) $value
}
if { [string equal -nocase $key "connection"]
&& [info exists state(bypass)]
} {
# Value supplied in -headers overrides $ConnVal.
set connection_seen 1
} elseif {[string equal -nocase $key "connection"]} {
# Remove "close" or "keep-alive" and use our own value.
# In an upgrade request, the upgrade is not guaranteed.
# Value "close" or "keep-alive" tells the server what to do
|
| ︙ | ︙ | |||
2445 2446 2447 2448 2449 2450 2451 |
# later, OR https handshake error, which may be discovered as late as
# the "flush" command above...
Log "WARNING - if testing, pay special attention to this\
case (GI) which is seldom executed - token $token"
if {[info exists state(reusing)] && $state(reusing)} {
# The socket was closed at the server end, and closed at
# this end by http::CheckEof.
| | | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
# later, OR https handshake error, which may be discovered as late as
# the "flush" command above...
Log "WARNING - if testing, pay special attention to this\
case (GI) which is seldom executed - token $token"
if {[info exists state(reusing)] && $state(reusing)} {
# The socket was closed at the server end, and closed at
# this end by http::CheckEof.
if {[TestForReplay $token write $err a]} {
return
} else {
Finish $token {failed to re-use socket}
}
# else:
# This is NOT a persistent socket that has been closed since its
|
| ︙ | ︙ | |||
2602 2603 2604 2605 2606 2607 2608 |
if {[package vsatisfies [package provide Tcl] 9.0-]} {
fconfigure $sock -profile replace
}
Log ^D$tk begin receiving response - token $token
coroutine ${token}--EventCoroutine http::Event $sock $token
if {[info exists state(-handler)] || [info exists state(-progress)]} {
| | | | 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 |
if {[package vsatisfies [package provide Tcl] 9.0-]} {
fconfigure $sock -profile replace
}
Log ^D$tk begin receiving response - token $token
coroutine ${token}--EventCoroutine http::Event $sock $token
if {[info exists state(-handler)] || [info exists state(-progress)]} {
fileevent $sock readable [list http::EventGateway $sock $token]
} else {
fileevent $sock readable ${token}--EventCoroutine
}
return
}
# http::EventGateway
#
|
| ︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 |
proc http::EventGateway {sock token} {
variable $token
upvar 0 $token state
fileevent $sock readable {}
catch {${token}--EventCoroutine} res opts
if {[info commands ${token}--EventCoroutine] ne {}} {
| | | | | | | | | | | 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 |
proc http::EventGateway {sock token} {
variable $token
upvar 0 $token state
fileevent $sock readable {}
catch {${token}--EventCoroutine} res opts
if {[info commands ${token}--EventCoroutine] ne {}} {
# The coroutine can be deleted by completion (a non-yield return), by
# http::Finish (when there is a premature end to the transaction), by
# http::reset or http::cleanup, or if the caller set option -channel
# but not option -handler: in the last case reading from the socket is
# now managed by commands ::http::Copy*, http::ReceiveChunked, and
# http::MakeTransformationChunked.
#
# Catch in case the coroutine has closed the socket.
catch {fileevent $sock readable [list http::EventGateway $sock $token]}
}
# If there was an error, re-throw it.
return -options $opts $res
}
|
| ︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 |
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
if {[info exists state(socketcoro)]} {
| | | | | 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 |
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
if {[info exists state(socketcoro)]} {
Log $token Cancel socket after-idle event (ReInit)
after cancel $state(socketcoro)
unset state(socketcoro)
}
# Don't alter state(status) - this would trigger http::wait if it is in use.
set tmpState $state(tmpState)
set tmpOpenCmd $state(tmpOpenCmd)
set tmpConnArgs $state(tmpConnArgs)
foreach name [array names state] {
|
| ︙ | ︙ | |||
3206 3207 3208 3209 3210 3211 3212 |
variable $token
upvar 0 $token state
return $state(currentsize)
}
proc http::requestHeaders {token args} {
set lenny [llength $args]
if {$lenny > 1} {
| | | | | | | | | | | | | | | | | | | | | | | | 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 |
variable $token
upvar 0 $token state
return $state(currentsize)
}
proc http::requestHeaders {token args} {
set lenny [llength $args]
if {$lenny > 1} {
return -code error {usage: ::http::requestHeaders token ?headerName?}
} else {
return [Meta $token request {*}$args]
}
}
proc http::responseHeaders {token args} {
set lenny [llength $args]
if {$lenny > 1} {
return -code error {usage: ::http::responseHeaders token ?headerName?}
} else {
return [Meta $token response {*}$args]
}
}
proc http::requestHeaderValue {token header} {
Meta $token request $header VALUE
}
proc http::responseHeaderValue {token header} {
Meta $token response $header VALUE
}
proc http::Meta {token who args} {
variable $token
upvar 0 $token state
if {$who eq {request}} {
set whom requestHeaders
} elseif {$who eq {response}} {
set whom meta
} else {
return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
}
set header [string tolower [lindex $args 0]]
set how [string tolower [lindex $args 1]]
set lenny [llength $args]
if {$lenny == 0} {
return $state($whom)
} elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} {
return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
} else {
set result {}
set combined {}
foreach {key value} $state($whom) {
if {$key eq $header} {
lappend result $key $value
append combined $value {, }
}
}
if {$lenny == 1} {
return $result
} else {
return [string range $combined 0 end-2]
}
}
}
# ------------------------------------------------------------------------------
# Proc http::responseInfo
# ------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
3279 3280 3281 3282 3283 3284 3285 |
# ------------------------------------------------------------------------------
proc http::responseInfo {token} {
variable $token
upvar 0 $token state
set result {}
foreach {key origin name} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 |
# ------------------------------------------------------------------------------
proc http::responseInfo {token} {
variable $token
upvar 0 $token state
set result {}
foreach {key origin name} {
stage STATE state
status STATE status
responseCode STATE responseCode
reasonPhrase STATE reasonPhrase
contentType STATE type
binary STATE binary
redirection RESP location
upgrade STATE upgrade
error ERROR -
postError STATE posterror
method STATE method
charset STATE charset
compression STATE coding
httpRequest STATE -protocol
httpResponse STATE httpResponse
url STATE url
connectionRequest REQ connection
connectionResponse RESP connection
connectionActual STATE connection
transferEncoding STATE transfer
totalPost STATE querylength
currentPost STATE queryoffset
totalSize STATE totalsize
currentSize STATE currentsize
proxyUsed STATE proxyUsed
} {
if {$origin eq {STATE}} {
if {[info exists state($name)]} {
dict set result $key $state($name)
} else {
# Should never come here
dict set result $key {}
}
} elseif {$origin eq {REQ}} {
dict set result $key [requestHeaderValue $token $name]
} elseif {$origin eq {RESP}} {
dict set result $key [responseHeaderValue $token $name]
} elseif {$origin eq {ERROR}} {
# Don't flood the dict with data. The command ::http::error is
# available.
if {[info exists state(error)]} {
set msg [lindex $state(error) 0]
} else {
set msg {}
}
dict set result $key $msg
} else {
# Should never come here
dict set result $key {}
}
}
return $result
}
proc http::error {token} {
variable $token
upvar 0 $token state
if {[info exists state(error)]} {
|
| ︙ | ︙ | |||
3373 3374 3375 3376 3377 3378 3379 |
rename ${token}--SocketCoroutine {}
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
if {[info exists state(socketcoro)]} {
| | | | | | | | | 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 |
rename ${token}--SocketCoroutine {}
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
if {[info exists state(socketcoro)]} {
Log $token Cancel socket after-idle event (cleanup)
after cancel $state(socketcoro)
unset state(socketcoro)
}
if {[info exists state]} {
unset state
}
return
}
# http::Connect
#
# This callback is made when an asynchronous connection completes.
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Sets the status of the connection, which unblocks
# the waiting geturl call
proc http::Connect {token proto phost srvurl} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
if {[catch {eof $state(sock)} tmp] || $tmp} {
set err "due to unexpected EOF"
} elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
# set err is done in test
} else {
# All OK
set state(state) connecting
fileevent $state(sock) writable {}
::http::Connected $token $proto $phost $srvurl
return
}
# Error cases.
|
| ︙ | ︙ | |||
3817 3818 3819 3820 3821 3822 3823 |
if {[info commands ${token}--EventCoroutine] ne {}} {
rename ${token}--EventCoroutine {}
}
if {[info commands ${token}--SocketCoroutine] ne {}} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(socketcoro)]} {
| | | | | 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 |
if {[info commands ${token}--EventCoroutine] ne {}} {
rename ${token}--EventCoroutine {}
}
if {[info commands ${token}--SocketCoroutine] ne {}} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(socketcoro)]} {
Log $token Cancel socket after-idle event (Finish)
after cancel $state(socketcoro)
unset state(socketcoro)
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
if { [info exists state(-command)]
&& (![info exists state(done-command-cb)])
|
| ︙ | ︙ | |||
4643 4644 4645 4646 4647 4648 4649 |
# ------------------------------------------------------------------------------
proc http::GuessType {token} {
variable $token
upvar 0 $token state
if {$state(type) ne {application/octet-stream}} {
| | | | | | | | | | 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 |
# ------------------------------------------------------------------------------
proc http::GuessType {token} {
variable $token
upvar 0 $token state
if {$state(type) ne {application/octet-stream}} {
return 0
}
set body $state(body)
# e.g. {<?xml version="1.0" encoding="utf-8"?> ...}
if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} {
return 0
}
# e.g. {<?xml version="1.0" encoding="utf-8"?>}
set contents [regsub -- {[[:space:]]+} $match { }]
set contents [string range [string tolower $contents] 6 end-2]
# e.g. {version="1.0" encoding="utf-8"}
# without excess whitespace or upper-case letters
if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} {
return 0
}
# The application/xml default encoding:
set res utf-8
set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents]
foreach tag $tagList {
regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
if {$name eq {encoding}} {
set res $value
}
}
set enc [CharsetToEncoding $res]
if {$enc eq "binary"} {
return 0
}
if {[package vsatisfies [package provide Tcl] 9.0-]} {
set state(body) [encoding convertfrom -profile replace $enc $state(body)]
} else {
set state(body) [encoding convertfrom $enc $state(body)]
}
set state(body) [string map {\r\n \n \r \n} $state(body)]
|
| ︙ | ︙ | |||
4725 4726 4727 4728 4729 4730 4731 |
# args A list of name-value pairs.
#
# Results:
# TODO
proc http::formatQuery {args} {
if {[llength $args] % 2} {
| | | | | | 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 |
# args A list of name-value pairs.
#
# Results:
# TODO
proc http::formatQuery {args} {
if {[llength $args] % 2} {
return \
-code error \
-errorcode [list HTTP BADARGCNT $args] \
{Incorrect number of arguments, must be an even number.}
}
set result ""
set sep ""
foreach i $args {
append result $sep [quoteString $i]
if {$sep eq "="} {
set sep &
|
| ︙ | ︙ | |||
4781 4782 4783 4784 4785 4786 4787 |
#
# Results:
# The current proxy settings
proc http::ProxyRequired {host} {
variable http
if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
| | | | | | 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 |
#
# Results:
# The current proxy settings
proc http::ProxyRequired {host} {
variable http
if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
return
}
if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} {
set port 8080
} else {
set port $http(-proxyport)
}
# Simple test (cf. autoproxy) for hosts that must be accessed directly,
# not through the proxy server.
foreach domain $http(-proxynot) {
if {[string match -nocase $domain $host]} {
return {}
}
}
return [list $http(-proxyhost) $port]
}
# http::CharsetToEncoding --
#
# Tries to map a given IANA charset to a tcl encoding. If no encoding
|
| ︙ | ︙ | |||
4921 4922 4923 4924 4925 4926 4927 |
catch {chan event $chan readable {}}
return
}
}
}
# http::SplitCommaSeparatedFieldValue --
| | | | 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 |
catch {chan event $chan readable {}}
return
}
}
}
# http::SplitCommaSeparatedFieldValue --
# Return the individual values of a comma-separated field value.
#
# Arguments:
# fieldValue Comma-separated header field value.
#
# Results:
# List of values.
proc http::SplitCommaSeparatedFieldValue {fieldValue} {
set r {}
foreach el [split $fieldValue ,] {
lappend r [string trim $el]
}
return $r
}
# http::GetFieldValue --
# Return the value of a header field.
#
# Arguments:
# headers Headers key-value list
# fieldName Name of header field whose value to return.
#
# Results:
# The value of the fieldName header field
|
| ︙ | ︙ | |||
5007 5008 5009 5010 5011 5012 5013 |
# ------------------------------------------------------------------------------
proc http::socketAsCallback {args} {
variable http
set targ [lsearch -exact $args -type]
if {$targ != -1} {
| | | | | | | | | | | | | | 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 |
# ------------------------------------------------------------------------------
proc http::socketAsCallback {args} {
variable http
set targ [lsearch -exact $args -type]
if {$targ != -1} {
set token [lindex $args $targ+1]
upvar 0 ${token} state
set protoProxyConn $state(protoProxyConn)
} else {
set protoProxyConn 0
}
set host [lindex $args end-1]
set port [lindex $args end]
if { ($http(-proxyfilter) ne {})
&& (![catch {$http(-proxyfilter) $host} proxy])
&& $protoProxyConn
} {
set phost [lindex $proxy 0]
set pport [lindex $proxy 1]
} else {
set phost {}
set pport {}
}
if {$phost eq ""} {
set sock [::http::AltSocket {*}$args]
} else {
set sock [::http::SecureProxyConnect {*}$args $phost $pport]
}
return $sock
}
# ------------------------------------------------------------------------------
# Proc http::SecureProxyConnect
|
| ︙ | ︙ | |||
5075 5076 5077 5078 5079 5080 5081 |
set args [lreplace $args end-3 end-2]
# Proxy server URL for connection.
# This determines where the socket is opened.
set phost [lindex $args end-1]
set pport [lindex $args end]
if {[string first : $phost] != -1} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 |
set args [lreplace $args end-3 end-2]
# Proxy server URL for connection.
# This determines where the socket is opened.
set phost [lindex $args end-1]
set pport [lindex $args end]
if {[string first : $phost] != -1} {
# IPv6 address, wrap it in [] so we can append :pport
set phost "\[${phost}\]"
}
set url http://${phost}:${pport}
# Elements of args other than host and port are not used when
# AsyncTransaction opens a socket. Those elements are -async and the
# -type $tokenName for the https transaction. Option -async is used by
# AsyncTransaction anyway, and -type $tokenName should not be
# propagated: the proxy request adds its own -type value.
set targ [lsearch -exact $args -type]
if {$targ != -1} {
# Record in the token that this is a proxy call.
set token [lindex $args $targ+1]
upvar 0 ${token} state
set tim $state(-timeout)
set state(proxyUsed) SecureProxyFailed
# This value is overwritten with "SecureProxy" below if the CONNECT is
# successful. If it is unsuccessful, the socket will be closed
# below, and so in this unsuccessful case there are no other transactions
# whose (proxyUsed) must be updated.
} else {
set tim 0
}
if {$tim == 0} {
# Do not use infinite timeout for the proxy.
set tim 30000
}
# Prepare and send a CONNECT request to the proxy, using
# code similar to http::geturl.
set requestHeaders [list Host $host]
lappend requestHeaders Connection keep-alive
if {$http(-proxyauth) != {}} {
lappend requestHeaders Proxy-Authorization $http(-proxyauth)
}
set token2 [CreateToken $url -keepalive 0 -timeout $tim \
-headers $requestHeaders -command [list http::AllDone $varName]]
variable $token2
upvar 0 $token2 state2
# Kludges:
# Setting this variable overrides the HTTP request line and also allows
# -headers to override the Connection: header set by -keepalive.
# The arguments "-keepalive 0" ensure that when Finish is called for an
# unsuccessful request, the socket is always closed.
set state2(bypass) "CONNECT $host:$port HTTP/1.1"
AsyncTransaction $token2
if {[info coroutine] ne {}} {
# All callers in the http package are coroutines launched by
# the event loop.
# The cwait command requires a coroutine because it yields
# to the caller; $varName is traced and the coroutine resumes
# when the variable is written.
cwait $varName
} else {
return -code error {code must run in a coroutine}
# For testing with a non-coroutine caller outside the http package.
# vwait $varName
}
unset $varName
if { ($state2(state) ne "complete")
|| ($state2(status) ne "ok")
|| (![string is integer -strict $state2(responseCode)])
} {
set msg {the HTTP request to the proxy server did not return a valid\
and complete response}
if {[info exists state2(error)]} {
append msg ": " [lindex $state2(error) 0]
}
cleanup $token2
return -code error $msg
}
set code $state2(responseCode)
if {($code >= 200) && ($code < 300)} {
# All OK. The caller in package tls will now call "tls::import $sock".
# The cleanup command does not close $sock.
# Other tidying was done in http::Event.
# If this is a persistent socket, any other transactions that are
# already marked to use the socket will have their (proxyUsed) updated
# when http::OpenSocket calls http::ConfigureNewSocket.
set state(proxyUsed) SecureProxy
set sock $state2(sock)
cleanup $token2
return $sock
}
if {$targ != -1} {
# Non-OK HTTP status code; token is known because option -type
# (cf. targ) was passed through tcltls, and so the useful
# parts of the proxy's response can be copied to state(*).
# Do not copy state2(sock).
# Return the proxy response to the caller of geturl.
foreach name $failedProxyValues {
if {[info exists state2($name)]} {
set state($name) $state2($name)
}
}
set state(connection) close
set msg "proxy connect failed: $code"
# - This error message will be detected by http::OpenSocket and will
# cause it to present the proxy's HTTP response as that of the
# original $token transaction, identified only by state(proxyUsed)
# as the response of the proxy.
# - The cases where this would mislead the caller of http::geturl are
# given a different value of msg (below) so that http::OpenSocket will
# treat them as errors, but will preserve the $token array for
|
| ︙ | ︙ | |||
5268 5269 5270 5271 5272 5273 5274 |
variable ThreadCounter
variable http
LoadThreadIfNeeded
set targ [lsearch -exact $args -type]
if {$targ != -1} {
| | | | | | | | | | | | | | | | | | | | | | | | | | 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 |
variable ThreadCounter
variable http
LoadThreadIfNeeded
set targ [lsearch -exact $args -type]
if {$targ != -1} {
set token [lindex $args $targ+1]
set args [lreplace $args $targ $targ+1]
upvar 0 $token state
}
if {$http(usingThread) && [info exists state] && $state(protoSockThread)} {
} else {
# Use plain "::socket". This is the default.
return [eval ::socket $args]
}
set defcmd ::socket
set sockargs $args
set script "
set code \[catch {
[list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
[list ::SockInThread [thread::id] $defcmd $sockargs]
} result opts\]
list \$code \$opts \$result
"
set state(tid) [thread::create]
set varName ::http::ThreadVar([incr ThreadCounter])
thread::send -async $state(tid) $script $varName
Log >T Thread Start Wait $args -- coro [info coroutine] $varName
if {[info coroutine] ne {}} {
# All callers in the http package are coroutines launched by
# the event loop.
# The cwait command requires a coroutine because it yields
# to the caller; $varName is traced and the coroutine resumes
# when the variable is written.
cwait $varName
} else {
return -code error {code must run in a coroutine}
# For testing with a non-coroutine caller outside the http package.
# vwait $varName
}
Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
thread::release $state(tid)
set state(tid) {}
set result [set $varName]
unset $varName
if {(![string is list $result]) || ([llength $result] != 3)} {
return -code error "result from peer thread is not a list of\
length 3: it is \n$result"
}
lassign $result threadCode threadDict threadResult
if {($threadCode != 0)} {
# This is an error in thread::send. Return the lot.
return -options $threadDict -code error $threadResult
}
# Now the results of the catch in the peer thread.
lassign $threadResult catchCode errdict sock
if {($catchCode == 0) && ($sock ni [chan names])} {
return -code error {Transfer of socket from peer thread failed.\
Check that this script is not running in a child interpreter.}
}
return -options $errdict -code $catchCode $sock
}
# The commands below are dependencies of http::AltSocket and
# http::SecureProxyConnect and are not used elsewhere.
|
| ︙ | ︙ | |||
5352 5353 5354 5355 5356 5357 5358 |
# Arguments: none
# Return Value: none
# ------------------------------------------------------------------------------
proc http::LoadThreadIfNeeded {} {
variable http
if {$http(-threadlevel) == 0} {
| | | | | | | | | | | 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 |
# Arguments: none
# Return Value: none
# ------------------------------------------------------------------------------
proc http::LoadThreadIfNeeded {} {
variable http
if {$http(-threadlevel) == 0} {
set http(usingThread) 0
return
}
if {[catch {package require Thread}]} {
if {$http(-threadlevel) == 2} {
set msg {[http::config -threadlevel] has value 2,\
but the Thread package is not available}
return -code error $msg
}
set http(usingThread) 0
return
}
set http(usingThread) 1
return
}
# ------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
5389 5390 5391 5392 5393 5394 5395 |
# ------------------------------------------------------------------------------
proc http::SockInThread {caller defcmd sockargs} {
package require Thread
set catchCode [catch {eval $defcmd $sockargs} sock errdict]
if {$catchCode == 0} {
| | | 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 |
# ------------------------------------------------------------------------------
proc http::SockInThread {caller defcmd sockargs} {
package require Thread
set catchCode [catch {eval $defcmd $sockargs} sock errdict]
if {$catchCode == 0} {
set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
}
return [list $catchCode $errdict $sock]
}
# ------------------------------------------------------------------------------
# Proc http::cwaiter::cwait
|
| ︙ | ︙ | |||
5426 5427 5428 5429 5430 5431 5432 |
}
proc http::cwaiter::cwait {
varName {coroName {}} {timeout {}} {timeoutValue {}}
} {
set thisCoro [info coroutine]
if {$thisCoro eq {}} {
| | | | | | | | 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 |
}
proc http::cwaiter::cwait {
varName {coroName {}} {timeout {}} {timeoutValue {}}
} {
set thisCoro [info coroutine]
if {$thisCoro eq {}} {
return -code error {cwait cannot be called outside a coroutine}
}
if {$coroName eq {}} {
set coroName $thisCoro
}
if {[string range $varName 0 1] ne {::}} {
return -code error {argument varName must be fully qualified}
}
if {$timeout eq {}} {
set toe {}
} elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
set toe [after $timeout [list set $varName $timeoutValue]]
} else {
return -code error {if timeout is supplied it must be a positive integer}
}
set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
trace add variable $varName write $cmd
CoLog "Yield $varName $coroName"
yield
CoLog "Resume $varName $coroName"
|
| ︙ | ︙ | |||
5497 5498 5499 5500 5501 5502 5503 |
return $log
}
proc http::cwaiter::CoLog {msg} {
variable log
variable logOn
if {$logOn} {
| | | 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 |
return $log
}
proc http::cwaiter::CoLog {msg} {
variable log
variable logOn
if {$logOn} {
append log $msg \n
}
return
}
namespace eval http {
namespace import ::http::cwaiter::*
}
# Local variables:
# indent-tabs-mode: t
# End:
|
Changes to library/http/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.10.0 [list tclPkgSetup $dir http 2.10.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Added library/icu.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 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 |
#----------------------------------------------------------------------
#
# icu.tcl --
#
# This file implements the portions of the [tcl::unsupported::icu]
# ensemble that are coded in Tcl.
#
#----------------------------------------------------------------------
#
# Copyright © 2024 Ashok P. Nadkarni
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#----------------------------------------------------------------------
::tcl::unsupported::loadIcu
namespace eval ::tcl::unsupported::icu {
# Map Tcl encoding names to ICU and back. Note ICU has multiple aliases
# for the same encoding.
variable tclToIcu
variable icuToTcl
proc LogError {message} {
puts stderr $message
}
proc Init {} {
variable tclToIcu
variable icuToTcl
# There are some special cases where names do not line up
# at all. Map Tcl -> ICU
array set specialCases {
ebcdic ebcdic-cp-us
macCentEuro maccentraleurope
utf16 UTF16_PlatformEndian
utf-16be UnicodeBig
utf-16le UnicodeLittle
utf32 UTF32_PlatformEndian
}
# Ignore all errors. Do not want to hold up Tcl
# if ICU not available
if {[catch {
foreach tclName [encoding names] {
if {[catch {
set icuNames [aliases $tclName]
} erMsg]} {
LogError "Could not get aliases for $tclName: $erMsg"
continue
}
if {[llength $icuNames] == 0} {
# E.g. macGreek -> x-MacGreek
set icuNames [aliases x-$tclName]
if {[llength $icuNames] == 0} {
# Still no joy, check for special cases
if {[info exists specialCases($tclName)]} {
set icuNames [aliases $specialCases($tclName)]
}
}
}
# If the Tcl name is also an ICU name use it else use
# the first name which is the canonical ICU name
set pos [lsearch -exact -nocase $icuNames $tclName]
if {$pos >= 0} {
lappend tclToIcu($tclName) [lindex $icuNames $pos] {*}[lreplace $icuNames $pos $pos]
} else {
set tclToIcu($tclName) $icuNames
}
foreach icuName $icuNames {
lappend icuToTcl($icuName) $tclName
}
}
} errMsg]} {
LogError $errMsg
}
array default set tclToIcu ""
array default set icuToTcl ""
# Redefine ourselves to no-op.
proc Init {} {}
}
# Primarily used during development
proc MappedIcuNames {{pat *}} {
Init
variable icuToTcl
return [array names icuToTcl $pat]
}
# Primarily used during development
proc UnmappedIcuNames {{pat *}} {
Init
variable icuToTcl
set unmappedNames {}
foreach icuName [converters] {
if {[llength [icuToTcl $icuName]] == 0} {
lappend unmappedNames $icuName
}
foreach alias [aliases $icuName] {
if {[llength [icuToTcl $alias]] == 0} {
lappend unmappedNames $alias
}
}
}
# Aliases can be duplicates. Remove
return [lsort -unique [lsearch -inline -all $unmappedNames $pat]]
}
# Primarily used during development
proc UnmappedTclNames {{pat *}} {
Init
variable tclToIcu
set unmappedNames {}
foreach tclName [encoding names] {
# Note entry will always exist. Check if empty
if {[llength [tclToIcu $tclName]] == 0} {
lappend unmappedNames $tclName
}
}
return [lsearch -inline -all $unmappedNames $pat]
}
# Returns the Tcl equivalent of an ICU encoding name or
# the empty string in case not found.
proc icuToTcl {icuName} {
Init
proc icuToTcl {icuName} {
variable icuToTcl
return [lindex $icuToTcl($icuName) 0]
}
icuToTcl $icuName
}
# Returns the ICU equivalent of an Tcl encoding name or
# the empty string in case not found.
proc tclToIcu {tclName} {
Init
proc tclToIcu {tclName} {
variable tclToIcu
return [lindex $tclToIcu($tclName) 0]
}
tclToIcu $tclName
}
namespace export {[a-z]*}
namespace ensemble create
}
|
Changes to library/init.tcl.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # # All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | < < < < | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # # All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require -exact tcl 9.0.2 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH # # tcl_library, which is the directory containing this init.tcl script. |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
#
# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
# ::auto_path (other than to {} if it is undefined). The caller, typically
# a Safe Base command, is responsible for setting ::auto_path.
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
| | | | | | | | | | > | 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 |
#
# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
# ::auto_path (other than to {} if it is undefined). The caller, typically
# a Safe Base command, is responsible for setting ::auto_path.
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
set auto_path [apply {{} {
lmap path $::env(TCLLIBPATH) {
# Paths relative to unresolvable home dirs are ignored
if {[catch {file tildeexpand $path} expanded_path]} {
continue
}
set expanded_path
}
}}]
} else {
set auto_path ""
}
}
namespace eval tcl {
if {![interp issafe]} {
variable Dir
foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
# Set up the 'clock' ensemble
| < | < < | | | < < < | < | | > | < | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
# Set up the 'clock' ensemble
apply {{} {
set cmdmap [dict create]
foreach cmd {add clicks format microseconds milliseconds scan seconds} {
dict set cmdmap $cmd ::tcl::clock::$cmd
}
namespace inscope ::tcl::clock [list namespace ensemble create -command \
::clock -map $cmdmap]
::tcl::unsupported::clock::configure -init-complete
}}
}
# Conditionalize for presence of exec.
if {[namespace which -command exec] eq ""} {
# Some machines do not have exec. Also, on all
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 366 367 368 369 370 371 |
# namespace (optional) The namespace where the command is being used - must be
# a canonical namespace as returned [namespace current]
# for instance. If not given, namespace current is used.
proc auto_load {cmd {namespace {}}} {
global auto_index auto_path
if {$namespace eq ""} {
set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
# workaround non canonical auto_index entries that might be around
# from older auto_mkindex versions
| > | > > | > | > | > < < < < < < | > > | < | 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 |
# namespace (optional) The namespace where the command is being used - must be
# a canonical namespace as returned [namespace current]
# for instance. If not given, namespace current is used.
proc auto_load {cmd {namespace {}}} {
global auto_index auto_path
# qualify names:
if {$namespace eq ""} {
set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
# workaround non canonical auto_index entries that might be around
# from older auto_mkindex versions
if {$cmd ni $nameList} {lappend nameList $cmd}
# try to load (and create sub-cmd handler "_sub_load_cmd" for further usage):
foreach name $nameList [set _sub_load_cmd {
# via auto_index:
if {[info exists auto_index($name)]} {
namespace inscope :: $auto_index($name)
# There's a couple of ways to look for a command of a given
# name. One is to use
# info commands $name
# Unfortunately, if the name has glob-magic chars in it like *
# or [], it may not match. For our purposes here, a better
# route is to use
# namespace which -command $name
if {[namespace which -command $name] ne ""} {
return 1
}
}
}]
# load auto_index if possible:
if {![info exists auto_path]} {
return 0
}
if {![auto_load_index]} {
return 0
}
# try again (something new could be loaded):
foreach name $nameList $_sub_load_cmd
return 0
}
# ::tcl::Pkg::source --
# This procedure provides an alternative "source" command, which doesn't
# register the file for the "package files" command. Safe interpreters
# don't have to do anything special.
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
| | | | | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
foreach name [array names auto_index $pattern] {
if {([namespace which -command $name] eq "")
&& ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
namespace inscope :: $auto_index($name)
}
}
}
}
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
return ""
}
| | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
return ""
}
set path "[file dirname [info nameofexecutable]];.;"
if {[info exists env(SystemRoot)]} {
set windir $env(SystemRoot)
} elseif {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
}
if {[info exists windir]} {
append path "$windir/system32;$windir/system;$windir;"
|
| ︙ | ︙ |
Changes to library/install.tcl.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
###
set fin [open $file r]
fconfigure $fin -encoding utf-8 -eofchar \x1A
set dat [read $fin]
close $fin
# Look for a teapot style Package statement
foreach line [split $dat \n] {
| | | | | | | | | | | | | | | | | | | | 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 |
###
set fin [open $file r]
fconfigure $fin -encoding utf-8 -eofchar \x1A
set dat [read $fin]
close $fin
# Look for a teapot style Package statement
foreach line [split $dat \n] {
set line [string trim $line]
if { [string range $line 0 9] != "# Package " } continue
set package [lindex $line 2]
set version [lindex $line 3]
break
}
# Look for a package provide statement
foreach line [split $dat \n] {
set line [string trim $line]
if { [string range $line 0 14] != "package provide" } continue
set package [lindex $line 2]
set version [lindex $line 3]
break
}
append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
}
foreach file [glob -nocomplain $path/*.tcl] {
if { [file tail $file] == "version_info.tcl" } continue
set fin [open $file r]
fconfigure $fin -encoding utf-8 -eofchar \x1A
set dat [read $fin]
close $fin
if {![regexp "package provide" $dat]} continue
set fname [file rootname [file tail $file]]
# Look for a package provide statement
foreach line [split $dat \n] {
set line [string trim $line]
if { [string range $line 0 14] != "package provide" } continue
set package [lindex $line 2]
set version [lindex $line 3]
if {[string index $package 0] in "\$ \[ @"} continue
if {[string index $version 0] in "\$ \[ @"} continue
append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
break
}
}
return $buffer
}
set fin [open $pkgidxfile r]
fconfigure $fin -encoding utf-8 -eofchar \x1A
set dat [read $fin]
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
if {[file tail $dir] eq "teapot"} continue
lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir]
}
set i [string length $base]
# Build a list of all of the paths
if {[llength $paths]} {
foreach path $paths {
| | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
if {[file tail $dir] eq "teapot"} continue
lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir]
}
set i [string length $base]
# Build a list of all of the paths
if {[llength $paths]} {
foreach path $paths {
if {$path eq $base} continue
set path_indexed($path) 0
}
} else {
puts [list WARNING: NO PATHS FOUND IN $base]
}
set path_indexed($base) 1
set path_indexed([file join $base boot tcl]) 1
foreach teapath [glob -nocomplain [file join $base teapot *]] {
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
}
}
foreach path $paths {
if {$path_indexed($path)} continue
set thisdir [file_relative $base $path]
set idxbuf [::practcl::_pkgindex_directory $path]
if {[string length $idxbuf]} {
| | | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 |
}
}
foreach path $paths {
if {$path_indexed($path)} continue
set thisdir [file_relative $base $path]
set idxbuf [::practcl::_pkgindex_directory $path]
if {[string length $idxbuf]} {
incr path_indexed($path)
append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n
append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n
}
}
}
append buffer {
set dir [lindex $::PATHSTACK end]
set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
}
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
installDir $f [file join $d2 $ftail]
} elseif {[file isfile $f]} {
file copy -force $f [file join $d2 $ftail]
if {$::tcl_platform(platform) eq {unix}} {
| | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
installDir $f [file join $d2 $ftail]
} elseif {[file isfile $f]} {
file copy -force $f [file join $d2 $ftail]
if {$::tcl_platform(platform) eq {unix}} {
file attributes [file join $d2 $ftail] -permissions 0o644
} else {
file attributes [file join $d2 $ftail] -readonly 1
}
}
}
if {$::tcl_platform(platform) eq {unix}} {
file attributes $d2 -permissions 0o755
} else {
|
| ︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 5 6 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set isafe [interp issafe]
foreach {safe package version file} {
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
###
# 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.10.0 {http http.tcl}
1 msgcat 1.7.1 {msgcat msgcat.tcl}
1 opt 0.4.9 {opt optparse.tcl}
0 cookiejar 0.2.0 {cookiejar cookiejar.tcl}
0 tcl::idna 1.0.1 {cookiejar idna.tcl}
0 platform 1.0.19 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.9 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
package ifneeded $package $version [list source [file join $dir {*}$file]]
}
}} $dir
|
Changes to library/msgcat/msgcat.tcl.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.7.1
namespace eval msgcat {
namespace export mc mcn mcexists mcload mclocale mcmax\
mcmset mcpreferences mcset\
| | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.7.1
namespace eval msgcat {
namespace export mc mcn mcexists mcload mclocale mcmax\
mcmset mcpreferences mcset\
mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
# Records the list of locales to search
variable Loclist {}
# List of currently loaded locales
variable LoadedLocales {}
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 |
if {[llength [info level 0]] == 4 } {
# value provided
if {$subcommand in {"get" "isset" "unset"}} {
return -code error "wrong # args: should be\
\"[lrange [info level 0] 0 2] value\""
}
} elseif {$subcommand eq "set"} {
| | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
if {[llength [info level 0]] == 4 } {
# value provided
if {$subcommand in {"get" "isset" "unset"}} {
return -code error "wrong # args: should be\
\"[lrange [info level 0] 0 2] value\""
}
} elseif {$subcommand eq "set"} {
return -code error\
"wrong # args: should be \"[lrange [info level 0] 0 2]\""
}
# Execute subcommands
switch -exact -- $subcommand {
get { # Operation get return current value
if {![dict exists $PackageConfig $option $ns]} {
|
| ︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 |
# helper function to find package namespace of stack-frame -2
# There are 4 possibilities:
# - called from a proc
# - called within a class definition script
# - called from an class defined oo object
# - called from a classless oo object
proc ::msgcat::PackageNamespaceGet {} {
| | > > > > > > > > | | | | < < < | | > | 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 |
# helper function to find package namespace of stack-frame -2
# There are 4 possibilities:
# - called from a proc
# - called within a class definition script
# - called from an class defined oo object
# - called from a classless oo object
proc ::msgcat::PackageNamespaceGet {} {
set ns [uplevel 2 { namespace current }]
if {![string match {::oo::*} $ns]} {
# Not in object environment
return $ns
}
# Ticket 91b3a5bb14: call to self may fail if namespace is stored
# so catch all this
try {
# Check self namespace to determine environment
switch -exact -- [uplevel 2 { namespace which -command self }] {
{::oo::define::self} {
# We are within a class definition
return [namespace qualifiers [uplevel 2 { self }]]
}
{::oo::Helpers::self} {
# We are within an object
set Class [info object class [uplevel 2 { self }]]
# Check for classless defined object
if {$Class eq {::oo::object}} {
return [namespace qualifiers [uplevel 2 { self }]]
}
# Class defined object
return [namespace qualifiers $Class]
}
}
} on error {} {
}
return $ns
}
# Initialize the default locale
proc msgcat::mcutil::getsystemlocale {} {
global env
#
|
| ︙ | ︙ |
Changes to library/msgcat/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
package ifneeded msgcat 1.7.1 [list source -encoding utf-8 [file join $dir msgcat.tcl]]
|
Changes to library/opt/optparse.tcl.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
# and the install directory in the Makefiles.
package provide opt 0.4.9
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
| | | | | | | | | | | | | | | | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
# and the install directory in the Makefiles.
package provide opt 0.4.9
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
Lempty Lget \
Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
SetMax SetMin
################# Example of use / 'user documentation' ###################
proc OptCreateTestProc {} {
# Defines ::tcl::OptParseTest as a test proc with parsed arguments
# (can't be defined before the code below is loaded (before "OptProc"))
# Every OptProc give usage information on "procname -help".
# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
# then other arguments.
#
# example of 'valid' call:
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
# -nostatics false ch1
OptProc OptParseTest {
{subcommand -choice {save print} "sub command"}
{arg1 3 "some number"}
{-aflag}
{-intflag 7}
{-weirdflag "help string"}
{-noStatics "Not ok to load static packages"}
{-nestedloading1 true "OK to load into nested children"}
{-nestedloading2 -boolean true "OK to load into nested children"}
{-libsOK -choice {Tk SybTcl}
"List of packages that can be loaded"}
{-precision -int 12 "Number of digits of precision"}
{-intval 7 "An integer"}
{-scale -float 1.0 "Scale factor"}
{-zoom 1.0 "Zoom factor"}
{-arbitrary foobar "Arbitrary string"}
{-random -string 12 "Random string"}
{-listval -list {} "List value"}
{-blahflag -blah abc "Funny type"}
{arg2 -boolean "a boolean"}
{arg3 -choice "ch1 ch2"}
{?optarg? -list {} "optional argument"}
} {
foreach v [info locals] {
puts stderr [format "%14s : %s" $v [set $v]]
}
}
}
################### No User serviceable part below ! ###############
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
variable OptDesc
variable OptDescN
if {[string equal $key ""]} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
variable OptDesc
variable OptDescN
if {[string equal $key ""]} {
# in case a key given to us as a parameter was a number
while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
set key $OptDescN
incr OptDescN
}
# program counter
set program [list [list "P" 1]]
# are we processing flags (which makes a single program step)
set inflags 0
set state {}
# flag used to detect that we just have a single (flags set) subprogram.
set empty 1
foreach item $desc {
if {$state == "args"} {
# more items after 'args'...
return -code error "'args' special argument must be the last one"
}
set res [OptNormalizeOne $item]
set state [lindex $res 0]
if {$inflags} {
if {$state == "flags"} {
# add to 'subprogram'
lappend flagsprg $res
} else {
# put in the flags
# structure for flag programs items is a list of
# {subprgcounter {prg flag 1} {prg flag 2} {...}}
lappend program $flagsprg
# put the other regular stuff
lappend program $res
set inflags 0
set empty 0
}
} else {
if {$state == "flags"} {
set inflags 1
# sub program counter + first sub program
set flagsprg [list [list "P" 1] $res]
} else {
lappend program $res
set empty 0
}
}
}
if {$inflags} {
if {$empty} {
# We just have the subprogram, optimize and remove
# unneeded level:
set program $flagsprg
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
proc ::tcl::OptKeyDelete {key} {
variable OptDesc
unset OptDesc($key)
}
# Get the parsed description stored under the given key.
proc OptKeyGetDesc {descKey} {
| | | | | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
proc ::tcl::OptKeyDelete {key} {
variable OptDesc
unset OptDesc($key)
}
# Get the parsed description stored under the given key.
proc OptKeyGetDesc {descKey} {
variable OptDesc
if {![info exists OptDesc($descKey)]} {
return -code error "Unknown option description key \"$descKey\""
}
set OptDesc($descKey)
}
# Parse entry point for people who don't want to register with a key,
# for instance because the description changes dynamically.
# (otherwise one should really use OptKeyRegister once + OptKeyParse
# as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 |
# and add a first line to the code to call the OptKeyParse proc
# Stores the list of variables that have been actually given by the user
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
set namespace [uplevel 1 [list ::namespace current]]
if {[string match "::*" $name] || [string equal $namespace "::"]} {
| | | | | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
# and add a first line to the code to call the OptKeyParse proc
# Stores the list of variables that have been actually given by the user
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
set namespace [uplevel 1 [list ::namespace current]]
if {[string match "::*" $name] || [string equal $namespace "::"]} {
# absolute name or global namespace, name is the key
set key $name
} else {
# we are relative to some non top level namespace:
set key "${namespace}::${name}"
}
OptKeyRegister $desc $key
uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]
return $key
}
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 |
lappend res [Lget $lst $idx]
}
return $res
}
# Advance to next description
proc OptNextDesc {descName} {
| | | | | | | | | | | | | | | | | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
lappend res [Lget $lst $idx]
}
return $res
}
# Advance to next description
proc OptNextDesc {descName} {
uplevel 1 [list Lvarincr $descName {0 1}]
}
# Get the current description, eventually descend
proc OptCurDesc {descriptions} {
lindex $descriptions [OptGetPrgCounter $descriptions]
}
# get the current description, eventually descend
# through sub programs as needed.
proc OptCurDescFinal {descriptions} {
set item [OptCurDesc $descriptions]
# Descend untill we get the actual item and not a sub program
while {[OptIsPrg $item]} {
set item [OptCurDesc $item]
}
return $item
}
# Current final instruction adress
proc OptCurAddr {descriptions {start {}}} {
set adress [OptGetPrgCounter $descriptions]
lappend start $adress
set item [lindex $descriptions $adress]
if {[OptIsPrg $item]} {
return [OptCurAddr $item $start]
} else {
return $start
}
}
# Set the value field of the current instruction.
proc OptCurSetValue {descriptionsName value} {
upvar $descriptionsName descriptions
# Get the current item full address.
set adress [OptCurAddr $descriptions]
# Use the 3rd field of the item (see OptValue / OptNewInst).
lappend adress 2
Lvarset descriptions $adress [list 1 $value]
# ^hasBeenSet flag
}
# Empty state means done/paste the end of the program.
proc OptState {item} {
lindex $item 0
}
# current state
proc OptCurState {descriptions} {
OptState [OptCurDesc $descriptions]
}
#######
# Arguments manipulation
# Returns the argument that has to be processed now.
proc OptCurrentArg {lst} {
lindex $lst 0
}
# Advance to next argument.
proc OptNextArg {argsName} {
uplevel 1 [list Lvarpop1 $argsName]
}
#######
# Loop over all descriptions, calling OptDoOne which will
# eventually eat all the arguments.
proc OptDoAll {descriptionsName argumentsName} {
upvar $descriptionsName descriptions
upvar $argumentsName arguments
# puts "entered DoAll"
# Nb: the places where "state" can be set are tricky to figure
# because DoOne sets the state to flagsValue and return -continue
# when needed...
set state [OptCurState $descriptions]
# We'll exit the loop in "OptDoOne" or when state is empty.
while 1 {
set curitem [OptCurDesc $descriptions]
# Do subprograms if needed, call ourselves on the sub branch
while {[OptIsPrg $curitem]} {
OptDoAll curitem arguments
# puts "done DoAll sub"
# Insert back the results in current tree
Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
$curitem
OptNextDesc descriptions
set curitem [OptCurDesc $descriptions]
set state [OptCurState $descriptions]
}
# puts "state = \"$state\" - arguments=($arguments)"
if {[Lempty $state]} {
# Nothing left to do, we are done in this branch:
break
}
# The following statement can make us terminate/continue
# as it use return -code {break, continue, return and error}
# codes
OptDoOne descriptions state arguments
# If we are here, no special return code where issued,
# we'll step to next instruction :
# puts "new state = \"$state\""
OptNextDesc descriptions
set state [OptCurState $descriptions]
}
}
# Process one step for the state machine,
# eventually consuming the current argument.
proc OptDoOne {descriptionsName stateName argumentsName} {
upvar $argumentsName arguments
upvar $descriptionsName descriptions
upvar $stateName state
# the special state/instruction "args" eats all
# the remaining args (if any)
if {($state == "args")} {
if {![Lempty $arguments]} {
# If there is no additional arguments, leave the default value
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
} else {
return -code error [OptMissingValue $descriptions]
}
} else {
set arg [OptCurrentArg $arguments]
}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
} else {
return -code error [OptMissingValue $descriptions]
}
} else {
set arg [OptCurrentArg $arguments]
}
switch $state {
flags {
# A non-dash argument terminates the options, as does --
# Still a flag ?
if {![OptIsFlag $arg]} {
# don't consume the argument, return to previous prg
return -code return
}
# consume the flag
OptNextArg arguments
if {[string equal "--" $arg]} {
# return from 'flags' state
return -code return
}
set hits [OptHits descriptions $arg]
if {$hits > 1} {
return -code error [OptAmbigous $descriptions $arg]
} elseif {$hits == 0} {
return -code error [OptFlagUsage $descriptions $arg]
}
set item [OptCurDesc $descriptions]
if {[OptNeedValue $item]} {
# we need a value, next state is
set state flagValue
} else {
OptCurSetValue descriptions 1
}
# continue
return -code continue
}
flagValue -
value {
set item [OptCurDesc $descriptions]
# Test the values against their required type
if {[catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
return -code error [OptBadValue $item $arg $val]
}
# consume the value
OptNextArg arguments
# set the value
OptCurSetValue descriptions $val
# go to next state
if {$state == "flagValue"} {
set state flags
return -code continue
} else {
set state next; # not used, for debug only
return ; # will go on next step
}
}
optValue {
set item [OptCurDesc $descriptions]
# Test the values against their required type
if {![catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
# right type, so :
# consume the value
OptNextArg arguments
# set the value
OptCurSetValue descriptions $val
}
# go to next state
set state next; # not used, for debug only
return ; # will go on next step
}
}
# If we reach this point: an unknown
# state as been entered !
return -code error "Bug! unknown state in DoOne \"$state\"\
(prg counter [OptGetPrgCounter $descriptions]:\
[OptCurDesc $descriptions])"
}
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# puts "checking '$arg' against '$type' ($typeArgs)"
# only types "any", "choice", and numbers can have leading "-"
switch -exact -- $type {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 |
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# puts "checking '$arg' against '$type' ($typeArgs)"
# only types "any", "choice", and numbers can have leading "-"
switch -exact -- $type {
int {
if {![string is integer -strict $arg]} {
error "not an integer"
}
return $arg
}
float {
return [expr {double($arg)}]
}
script -
list {
# if llength fail : malformed list
if {[llength $arg]==0 && [OptIsFlag $arg]} {
error "no values with leading -"
}
return $arg
}
boolean {
if {![string is boolean -strict $arg]} {
error "non canonic boolean"
}
# convert true/false because expr/if is broken with "!,...
return [expr {$arg ? 1 : 0}]
}
choice {
if {$arg ni $typeArgs} {
error "invalid choice"
}
return $arg
}
any {
return $arg
}
string -
default {
if {[OptIsFlag $arg]} {
error "no values with leading -"
}
return $arg
}
}
return neverReached
}
# internal utilities
# returns the number of flags matching the given arg
# sets the (local) prg counter to the list of matches
proc OptHits {descName arg} {
upvar $descName desc
set hits 0
set hitems {}
set i 1
set larg [string tolower $arg]
set len [string length $larg]
set last [expr {$len-1}]
foreach item [lrange $desc 1 end] {
set flag [OptName $item]
# lets try to match case insensitively
# (string length ought to be cheap)
set lflag [string tolower $flag]
if {$len == [string length $lflag]} {
if {[string equal $larg $lflag]} {
# Exact match case
OptSetPrgCounter desc $i
return 1
}
} elseif {[string equal $larg [string range $lflag 0 $last]]} {
lappend hitems $i
incr hits
}
incr i
}
if {$hits} {
OptSetPrgCounter desc $hitems
}
return $hits
}
# Extract fields from the list structure:
proc OptName {item} {
lindex $item 1
}
proc OptHasBeenSet {item} {
Lget $item {2 0}
}
proc OptValue {item} {
Lget $item {2 1}
}
proc OptIsFlag {name} {
string match "-*" $name
}
proc OptIsOpt {name} {
string match {\?*} $name
}
proc OptVarName {item} {
set name [OptName $item]
if {[OptIsFlag $name]} {
return [string range $name 1 end]
} elseif {[OptIsOpt $name]} {
return [string trim $name "?"]
} else {
return $name
}
}
proc OptType {item} {
lindex $item 3
}
proc OptTypeArgs {item} {
lindex $item 4
}
proc OptHelp {item} {
lindex $item 5
}
proc OptNeedValue {item} {
expr {![string equal [OptType $item] boolflag]}
}
proc OptDefaultValue {item} {
set val [OptTypeArgs $item]
switch -exact -- [OptType $item] {
choice {return [lindex $val 0]}
boolean -
boolflag {
# convert back false/true to 0/1 because expr !$bool
# is broken..
if {$val} {
return 1
} else {
return 0
}
}
}
return $val
}
# Description format error helper
proc OptOptUsage {item {what ""}} {
return -code error "invalid description format$what: $item\n\
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
?helpstring?}"
}
# Generate a canonical form single instruction
proc OptNewInst {state varname type typeArgs help} {
list $state $varname [list 0 {}] $type $typeArgs $help
# ^ ^
# | |
# hasBeenSet=+ +=currentValue
}
# Translate one item to canonical form
proc OptNormalizeOne {item} {
set lg [Lassign $item varname arg1 arg2 arg3]
# puts "called optnormalizeone '$item' v=($varname), lg=$lg"
set isflag [OptIsFlag $varname]
set isopt [OptIsOpt $varname]
if {$isflag} {
set state "flags"
} elseif {$isopt} {
set state "optValue"
} elseif {![string equal $varname "args"]} {
set state "value"
} else {
set state "args"
}
# apply 'smart' 'fuzzy' logic to try to make
# description writer's life easy, and our's difficult :
# let's guess the missing arguments :-)
switch $lg {
1 {
if {$isflag} {
return [OptNewInst $state $varname boolflag false ""]
} else {
return [OptNewInst $state $varname any "" ""]
}
}
2 {
# varname default
# varname help
set type [OptGuessType $arg1]
if {[string equal $type "string"]} {
if {$isflag} {
set type boolflag
set def false
} else {
set type any
set def ""
}
set help $arg1
} else {
set help ""
set def $arg1
}
return [OptNewInst $state $varname $type $def $help]
}
3 {
# varname type value
# varname value comment
if {[regexp {^-(.+)$} $arg1 x type]} {
# flags/optValue as they are optional, need a "value",
# on the contrary, for a variable (non optional),
# default value is pointless, 'cept for choices :
if {$isflag || $isopt || ($type == "choice")} {
return [OptNewInst $state $varname $type $arg2 ""]
} else {
return [OptNewInst $state $varname $type "" $arg2]
}
} else {
return [OptNewInst $state $varname\
[OptGuessType $arg1] $arg1 $arg2]
}
}
4 {
if {[regexp {^-(.+)$} $arg1 x type]} {
return [OptNewInst $state $varname $type $arg2 $arg3]
} else {
return -code error [OptOptUsage $item]
}
}
default {
return -code error [OptOptUsage $item]
}
}
}
# Auto magic lazy type determination
proc OptGuessType {arg} {
if { $arg == "true" || $arg == "false" } {
return boolean
}
if {[string is integer -strict $arg]} {
return int
}
if {[string is double -strict $arg]} {
return float
}
return string
}
# Error messages front ends
proc OptAmbigous {desc arg} {
OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
}
proc OptFlagUsage {desc arg} {
OptError "bad flag \"$arg\", must be one of" $desc
}
proc OptTooManyArgs {desc arguments} {
OptError "too many arguments (unexpected argument(s): $arguments),\
usage:"\
$desc 1
}
proc OptParamType {item} {
if {[OptIsFlag $item]} {
return "flag"
} else {
return "parameter"
}
}
proc OptBadValue {item arg {err {}}} {
# puts "bad val err = \"$err\""
OptError "bad value \"$arg\" for [OptParamType $item]"\
[list $item]
}
proc OptMissingValue {descriptions} {
# set item [OptCurDescFinal $descriptions]
set item [OptCurDesc $descriptions]
OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
(use -help for full usage) :"\
[list $item]
}
proc ::tcl::OptKeyError {prefix descKey {header 0}} {
OptError $prefix [OptKeyGetDesc $descKey] $header
}
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
proc ::tcl::Lempty {list} {
expr {[llength $list]==0}
}
# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
| | | | | | | | | | | | | | | | | | | | | | | | | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 |
proc ::tcl::Lempty {list} {
expr {[llength $list]==0}
}
# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
return [lindex $list $indexLst]
}
Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]
}
# Sets the value of one leaf of a lists tree
# (we use the version that does not create the elements because
# it would be even slower... needs to be written in C !)
# (nb: there is a non trivial recursive problem with indexes 0,
# which appear because there is no difference between a list
# of 1 element and 1 element alone : [list "a"] == "a" while
# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
# and [listp "a b"] maybe 0. listp does not exist either...)
proc ::tcl::Lvarset {listName indexLst newValue} {
upvar $listName list
if {[llength $indexLst] <= 1} {
Lvarset1nc list $indexLst $newValue
} else {
set idx [lindex $indexLst 0]
set targetList [lindex $list $idx]
# reduce refcount on targetList (not really usefull now,
# could be with optimizing compiler)
# Lvarset1 list $idx {}
# recursively replace in targetList
Lvarset targetList [lrange $indexLst 1 end] $newValue
# put updated sub list back in the tree
Lvarset1nc list $idx $targetList
}
}
# Set one cell to a value, eventually create all the needed elements
# (on level-1 of lists)
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
upvar $listName list
if {$index < 0} {return -code error "invalid negative index"}
set lg [llength $list]
if {$index >= $lg} {
variable emptyList
for {set i $lg} {$i<$index} {incr i} {
lappend list $emptyList
}
lappend list $newValue
} else {
set list [lreplace $list $index $index $newValue]
}
}
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue} {
upvar $listName list
set list [lreplace $list $index $index $newValue]
}
# Increments the value of one leaf of a lists tree
# (which must exists)
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
upvar $listName list
if {[llength $indexLst] <= 1} {
Lvarincr1 list $indexLst $howMuch
} else {
set idx [lindex $indexLst 0]
set targetList [lindex $list $idx]
# reduce refcount on targetList
Lvarset1nc list $idx {}
# recursively replace in targetList
Lvarincr targetList [lrange $indexLst 1 end] $howMuch
# put updated sub list back in the tree
Lvarset1nc list $idx $targetList
}
}
# Increments the value of one cell of a list
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
upvar $listName list
set newValue [expr {[lindex $list $index]+$howMuch}]
set list [lreplace $list $index $index $newValue]
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 |
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
# faster than direct blown foreach (which does not byte compile)
set i 0
set lg [llength $list]
foreach vname $args {
| | | | | | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 |
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
# faster than direct blown foreach (which does not byte compile)
set i 0
set lg [llength $list]
foreach vname $args {
if {$i>=$lg} break
uplevel 1 [list ::set $vname [lindex $list $i]]
incr i
}
return $lg
}
# Misc utilities
# Set the varname to value if value is greater than varname's current value
# or if varname is undefined
proc ::tcl::SetMax {varname value} {
upvar 1 $varname var
if {![info exists var] || $value > $var} {
set var $value
}
}
# Set the varname to value if value is smaller than varname's current value
# or if varname is undefined
proc ::tcl::SetMin {varname value} {
upvar 1 $varname var
if {![info exists var] || $value < $var} {
set var $value
}
}
# everything loaded fine, lets create the test proc:
# OptCreateTestProc
# Don't need the create temp proc anymore:
# rename OptCreateTestProc {}
}
|
Changes to library/opt/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded opt 0.4.9 [list source -encoding utf-8 [file join $dir optparse.tcl]]
|
Changes to library/package.tcl.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 |
# Results:
# Returns 1 if the extension matches, 0 otherwise
proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
global tcl_platform
if {$ext eq ""} {set ext [info sharedlibextension]}
if {$tcl_platform(platform) eq "windows"} {
| | | | | | | | | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
# Results:
# Returns 1 if the extension matches, 0 otherwise
proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
global tcl_platform
if {$ext eq ""} {set ext [info sharedlibextension]}
if {$tcl_platform(platform) eq "windows"} {
return [string equal -nocase [file extension $fileName] $ext]
} else {
# Some unices add trailing numbers after the .so, so
# we could have something like '.so.1.2'.
set root $fileName
while {1} {
set currExt [file extension $root]
if {$currExt eq $ext} {
return 1
}
# The current extension does not match; if it is not a numeric
# value, quit, as we are only looking to ignore version number
# extensions. Otherwise we might return 1 in this case:
# tcl::Pkg::CompareExtension foo.so.bar .so
# which should not match.
if {![string is integer -strict [string range $currExt 1 end]]} {
return 0
}
set root [file rootname $root]
}
}
}
# pkg_mkIndex --
# This procedure creates a package index in a given directory. The package
# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that
|
| ︙ | ︙ | |||
500 501 502 503 504 505 506 |
# $file was not readable; silently ignore
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
continue
}
| | | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 |
# $file was not readable; silently ignore
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
continue
}
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
}
}
set dir [lindex $use_path end]
|
| ︙ | ︙ | |||
608 609 610 611 612 613 614 |
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
| | | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
if {[regexp {version conflict for package} $msg]} {
# In case of version conflict, silently ignore
continue
}
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
}
|
| ︙ | ︙ |
Changes to library/platform/pkgIndex.tcl.
|
| | | | 1 2 3 | package ifneeded platform 1.0.19 [list source -encoding utf-8 [file join $dir platform.tcl]] package ifneeded platform::shell 1.1.4 [list source -encoding utf-8 [file join $dir shell.tcl]] |
Changes to library/platform/shell.tcl.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 |
LOCATE base out
set code {}
# Forget any preexisting platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
| | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
LOCATE base out
set code {}
# Forget any preexisting platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
lappend code [list source -encoding utf-8 $base]
# Query and print the architecture
lappend code {puts [platform::generic]}
# And done
lappend code {exit 0}
set arch [RUN $shell [join $code \n]]
|
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
LOCATE base out
set code {}
# Forget any preexisting platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
| | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
LOCATE base out
set code {}
# Forget any preexisting platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
lappend code [list source -encoding utf-8 $base]
# Query and print the architecture
lappend code {puts [platform::identify]}
# And done
lappend code {exit 0}
set arch [RUN $shell [join $code \n]]
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
set cc [open $c w]
puts $cc $code
close $cc
set e [TEMP]
set code [catch {
| | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
set cc [open $c w]
puts $cc $code
close $cc
set e [TEMP]
set code [catch {
exec $shell $c 2> $e
} res]
file delete $c
if {$code} {
append res \n[read [set chan [open $e r]]][close $chan]
file delete $e
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
set maxtries 10
set access [list RDWR CREAT EXCL TRUNC]
set permission 0600
set channel ""
set checked_dir_writable 0
set mypid [pid]
for {set i 0} {$i < $maxtries} {incr i} {
| | | | | | | | | | | | | | | | | | | | | | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
set maxtries 10
set access [list RDWR CREAT EXCL TRUNC]
set permission 0600
set channel ""
set checked_dir_writable 0
set mypid [pid]
for {set i 0} {$i < $maxtries} {incr i} {
set newname $prefix
for {set j 0} {$j < $nrand_chars} {incr j} {
append newname [string index $chars \
[expr {int(rand()*62)}]]
}
set newname [file join $tmpdir $newname]
if {[file exists $newname]} {
after 1
} else {
if {[catch {open $newname $access $permission} channel]} {
if {!$checked_dir_writable} {
set dirname [file dirname $newname]
if {![file writable $dirname]} {
return -code error "Directory $dirname is not writable"
}
set checked_dir_writable 1
}
} else {
# Success
close $channel
return [file normalize $newname]
}
}
}
if {$channel ne ""} {
return -code error "Failed to open a temporary file: $channel"
} else {
return -code error "Failed to find an unused temporary file name"
}
}
proc ::platform::shell::DIR {} {
# This code is copied out of Tcllib's fileutil package.
# (TempDir/tempdir)
|
| ︙ | ︙ |
Changes to library/safe.tcl.
| ︙ | ︙ | |||
76 77 78 79 80 81 82 |
#
####
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
variable AutoPathSync
if {$AutoPathSync} {
| | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
#
####
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
variable AutoPathSync
if {$AutoPathSync} {
set autoPath {}
}
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
RejectExcessColons $child
set withAutoPath [::tcl::OptProcArgGiven -autoPath]
InterpCreate $child $accessPath \
[InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath
}
proc ::safe::interpInit {args} {
variable AutoPathSync
if {$AutoPathSync} {
set autoPath {}
}
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $child]} {
return -code error "\"$child\" is not an interpreter"
}
RejectExcessColons $child
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 | CheckInterp $child namespace upvar ::safe [VarName $child] state set TMP [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ | | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 |
CheckInterp $child
namespace upvar ::safe [VarName $child] state
set TMP [list \
[list -accessPath $state(access_path)] \
[list -statics $state(staticsok)] \
[list -nested $state(nestedok)] \
[list -deleteHook $state(cleanupHook)] \
]
if {!$AutoPathSync} {
lappend TMP [list -autoPath $state(auto_path)]
}
return [join $TMP]
}
2 {
# If we have exactly 2 arguments the semantic is a "configure
# get"
lassign $args child arg
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
set name [::tcl::OptName $item]
switch -exact -- $name {
-accessPath {
return [list -accessPath $state(access_path)]
}
-autoPath {
if {$AutoPathSync} {
| | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
set name [::tcl::OptName $item]
switch -exact -- $name {
-accessPath {
return [list -accessPath $state(access_path)]
}
-autoPath {
if {$AutoPathSync} {
return -code error "unknown flag $name (bug)"
} else {
return [list -autoPath $state(auto_path)]
}
}
-statics {
return [list -statics $state(staticsok)]
}
-nested {
return [list -nested $state(nestedok)]
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
set raw_auto_path $access_path
# Add 1st level subdirs (will searched by auto loading from tcl
# code in the child using glob and thus fail, so we add them here
# so by default it works the same).
set access_path [AddSubDirs $access_path]
} else {
| | | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
set raw_auto_path $access_path
# Add 1st level subdirs (will searched by auto loading from tcl
# code in the child using glob and thus fail, so we add them here
# so by default it works the same).
set access_path [AddSubDirs $access_path]
} else {
set raw_auto_path $autoPath
}
if {$withAutoPath} {
set raw_auto_path $autoPath
}
Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
if {!$AutoPathSync} {
Log $child "Setting auto_path=($raw_auto_path)" NOTICE
}
namespace upvar ::safe [VarName $child] state
# clear old autopath if it existed
# build new one
# Extend the access list with the paths used to look for Tcl Modules.
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 |
set addpaths $morepaths
set morepaths {}
foreach dir $addpaths {
# Prevent the addition of dirs on the tm list to the
# result if they are already known.
if {[dict exists $remap_access_path $dir]} {
| | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
set addpaths $morepaths
set morepaths {}
foreach dir $addpaths {
# Prevent the addition of dirs on the tm list to the
# result if they are already known.
if {[dict exists $remap_access_path $dir]} {
if {$firstpass} {
# $dir is in [::tcl::tm::list] and belongs in the child_tm_path.
# Later passes handle subdirectories, which belong in the
# access path but not in the module path.
lappend child_tm_path [dict get $remap_access_path $dir]
}
continue
}
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 |
set state(access_path,child) $child_access_path
set state(tm_path_child) $child_tm_path
set state(staticsok) $staticsok
set state(nestedok) $nestedok
set state(cleanupHook) $deletehook
if {!$AutoPathSync} {
| | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 |
set state(access_path,child) $child_access_path
set state(tm_path_child) $child_tm_path
set state(staticsok) $staticsok
set state(nestedok) $nestedok
set state(cleanupHook) $deletehook
if {!$AutoPathSync} {
set state(auto_path) $raw_auto_path
}
SyncAccessPath $child
return
}
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
# When an interpreter is deleted with [interp delete], any sub-interpreters
# are deleted automatically, but this leaves behind their data in the Safe
# Base. To clean up properly, we call safe::interpDelete recursively on each
# Safe Base sub-interpreter, so each one is deleted cleanly and not by
# the automatic mechanism built into [interp delete].
foreach sub [interp children $child] {
| | | | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
# When an interpreter is deleted with [interp delete], any sub-interpreters
# are deleted automatically, but this leaves behind their data in the Safe
# Base. To clean up properly, we call safe::interpDelete recursively on each
# Safe Base sub-interpreter, so each one is deleted cleanly and not by
# the automatic mechanism built into [interp delete].
foreach sub [interp children $child] {
if {[info exists ::safe::[VarName [list $child $sub]]]} {
::safe::interpDelete [list $child $sub]
}
}
# If the child has a cleanup hook registered, call it. Check the
# existence because we might be called to delete an interp which has
# not been registered with us at all
if {[info exists state(cleanupHook)]} {
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 |
set f [open $realfile]
fconfigure $f -encoding $encoding -eofchar \x1A
set contents [read $f]
close $f
::interp eval $child [list info script $file]
} msg opt]
if {$code == 0} {
set code [catch {::interp eval $child $contents} msg opt]
set replacementMsg $msg
}
catch {interp eval $child [list info script $old]}
# Note that all non-errors are fine result codes from [source], so we must
# take a little care to do it properly. [Bug 2923613]
if {$code == 1} {
| > > > > | 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
set f [open $realfile]
fconfigure $f -encoding $encoding -eofchar \x1A
set contents [read $f]
close $f
::interp eval $child [list info script $file]
} msg opt]
if {$code == 0} {
# See [Bug 1d26e580cf]
if {[string index $contents 0] eq "\uFEFF"} {
set contents [string range $contents 1 end]
}
set code [catch {::interp eval $child $contents} msg opt]
set replacementMsg $msg
}
catch {interp eval $child [list info script $old]}
# Note that all non-errors are fine result codes from [source], so we must
# take a little care to do it properly. [Bug 2923613]
if {$code == 1} {
|
| ︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 |
# becomes
# namespace upvar ::safe [VarName $child] state
# ------------------------------------------------------------------------------
proc ::safe::RejectExcessColons {child} {
set stripped [regsub -all -- {:::*} $child ::]
if {[string range $stripped end-1 end] eq {::}} {
| | | | | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 |
# becomes
# namespace upvar ::safe [VarName $child] state
# ------------------------------------------------------------------------------
proc ::safe::RejectExcessColons {child} {
set stripped [regsub -all -- {:::*} $child ::]
if {[string range $stripped end-1 end] eq {::}} {
return -code error {interpreter name must not end in "::"}
}
if {$stripped ne $child} {
set msg {interpreter name has excess colons in namespace separators}
return -code error $msg
}
if {[string range $stripped 0 1] eq {::}} {
return -code error {interpreter name must not begin "::"}
}
return
}
proc ::safe::VarName {child} {
# return S$child
return S[string map {:: @N @ @A} $child]
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
{-noStatics "prevent loading of statically linked pkgs"}
{-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
{-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
}
if {!$AutoPathSync} {
| | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 |
{-noStatics "prevent loading of statically linked pkgs"}
{-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
{-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
}
if {!$AutoPathSync} {
lappend OptList {-autoPath -list {} "::auto_path for the child"}
}
set temp [::tcl::OptKeyRegister $OptList]
# create case (child is optional)
::tcl::OptKeyRegister {
{?child? -name {} "name of the child (optional)"}
} ::safe::interpCreate
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 |
# because Setup has not yet been called.)
proc ::safe::setSyncMode {args} {
variable AutoPathSync
if {[llength $args] == 0} {
} elseif {[llength $args] == 1} {
| | | | | | | | | | | | | | | | | | | | | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 |
# because Setup has not yet been called.)
proc ::safe::setSyncMode {args} {
variable AutoPathSync
if {[llength $args] == 0} {
} elseif {[llength $args] == 1} {
set newValue [lindex $args 0]
if {![string is boolean -strict $newValue]} {
return -code error "new value must be a valid boolean"
}
set args [expr {$newValue && $newValue}]
if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
return -code error \
"cannot set new value while Safe Base child interpreters exist"
}
if {($args != $AutoPathSync)} {
set AutoPathSync {*}$args
::tcl::OptKeyDelete ::safe::interpCreate
::tcl::OptKeyDelete ::safe::interpIC
set TmpLog [setLogCmd]
Setup
setLogCmd $TmpLog
}
} else {
set msg {wrong # args: should be "safe::setSyncMode ?newValue?"}
return -code error $msg
}
return $AutoPathSync
}
namespace eval ::safe {
# internal variables (must not begin with "S")
|
| ︙ | ︙ |
Changes to library/tclIndex.
1 | # Tcl autoload index file, version 2.0 | < > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > | > > > | | > > > > > > > > | < < < < < < | 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 | # Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(auto_reset) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(tcl_findLibrary) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(auto_mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(auto_mkindex_old) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::init) [list ::tcl::Pkg::source [file join $dir auto.tcl]] 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(::auto_mkindex_parser::indexEntry) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::tcl::clock::Initialize) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::mcget) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::mcMerge) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::GetSystemLocale) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::EnterLocale) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::_hasRegistry) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::LoadWindowsDateTimeFormats) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::LocalizeFormat) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::GetSystemTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::SetupTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::GuessWindowsTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::LoadTimeZoneFile) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::LoadZoneinfoFile) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::ReadZoneinfoFile) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::ParsePosixTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::ProcessPosixTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::DeterminePosixDSTTime) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::GetJulianDayFromEraYearDay) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::GetJulianDayFromEraYearMonthWeekDay) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::IsGregorianLeapYear) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::WeekdayOnOrBefore) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::ChangeCurrentLocale) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(::tcl::clock::ClearCaches) [list ::tcl::Pkg::source [file join $dir clock.tcl]] set auto_index(foreachLine) [list ::tcl::Pkg::source [file join $dir foreachline.tcl]] set auto_index(::tcl::history) [list ::tcl::Pkg::source [file join $dir history.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(::tcl::HistNextID) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::Pkg::CompareExtension) [list ::tcl::Pkg::source [file join $dir package.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]] set auto_index(::safe::InterpSetConfig) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::DetokPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpFindInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpAddToAccessPath) [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::AddSubDirs) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpDelete) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::setLogCmd) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::SyncAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::PathToken) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::TranslatePath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::Log) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::CheckFileName) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasFileSubcommand) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasGlob) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasSource) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasLoad) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::FileInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::DirInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::BadSubcommand) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasEncodingSystem) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasExeName) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::RejectExcessColons) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::VarName) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::Setup) [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::tm::path) [list ::tcl::Pkg::source [file join $dir tm.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::UnknownHandler) [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::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::UpdateWordBreakREs) [list ::tcl::Pkg::source [file join $dir word.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::unsupported::icu) [list ::tcl::Pkg::source [file join $dir icu.tcl]] |
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded tcltest 2.5.9 [list source -encoding utf-8 [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
# All rights reserved.
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
| | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# All rights reserved.
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.5.9
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package require] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package require Tcl 8.5-]
variable patchLevel [info patchlevel]
|
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
makeFile removeDirectory removeFile runAllTests test
# Export configuration commands that control the functional commands
namespace export configure customMatch errorChannel interpreter \
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
makeFile removeDirectory removeFile runAllTests test
# Export configuration commands that control the functional commands
namespace export configure customMatch errorChannel interpreter \
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
if {![package vsatisfies [package provide Tcl] 9.0-]} {
namespace export bytestring ;# dups [encoding convertfrom identity]
}
namespace export debug ;# [configure -debug]
namespace export errorFile ;# [configure -errfile]
namespace export limitConstraints ;# [configure -limitconstraints]
namespace export loadFile ;# [configure -loadfile]
namespace export loadScript ;# [configure -load]
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 |
return -code error $msg
} else {
set Option($option) $msg
}
unset $varName
}
namespace eval [namespace current] \
| | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 |
return -code error $msg
} else {
set Option($option) $msg
}
unset $varName
}
namespace eval [namespace current] \
[list upvar 0 Option($option) $varName]
# Workaround for Bug (now Feature Request) 572889. Grrrr....
# Track all the variables tied to options
lappend OptionControlledVariables $varName
# Later, set auto-configure read traces on all
# of them, since a single trace on Option does not work.
proc $varName {{value {}}} [subst -nocommands {
if {[llength [info level 0]] == 2} {
|
| ︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 |
#
# Side effects:
# None.
proc tcltest::Asciify {s} {
set print ""
foreach c [split $s ""] {
| | | | | | | | | | | 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
#
# Side effects:
# None.
proc tcltest::Asciify {s} {
set print ""
foreach c [split $s ""] {
if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} {
append print $c
} elseif {$c < "\u0100"} {
append print \\x[format %02X [scan $c %c]]
} elseif {$c > "\uFFFF"} {
append print \\U[format %08X [scan $c %c]]
} else {
append print \\u[format %04X [scan $c %c]]
}
}
return $print
}
# tcltest::ConstraintInitializer --
#
# Get or set a script that when evaluated in the tcltest namespace
|
| ︙ | ︙ | |||
1278 1279 1280 1281 1282 1283 1284 |
ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
ConstraintInitializer winCrash {expr {![testConstraint win]}}
ConstraintInitializer macCrash {expr {![testConstraint mac]}}
ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
# Skip empty tests
| | | | > > > > | | 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 |
ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
ConstraintInitializer winCrash {expr {![testConstraint win]}}
ConstraintInitializer macCrash {expr {![testConstraint mac]}}
ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
# Skip empty tests
ConstraintInitializer emptyTest {expr 0}
# By default, tests that expose known bugs are skipped.
ConstraintInitializer knownBug {expr 0}
# By default, non-portable tests are skipped.
ConstraintInitializer nonPortable {expr 0}
# By default, extremely slow, extensive or IO-aggressive tests are skipped.
ConstraintInitializer extensive {expr 0}
# Some tests require user interaction.
ConstraintInitializer userInteraction {expr 0}
# Some tests must be skipped if the interpreter is not in
# interactive mode
ConstraintInitializer interactive \
{expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
|
| ︙ | ︙ | |||
1339 1340 1341 1342 1343 1344 1345 |
ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
# Test to see if execed commands such as cat, echo, rm and so forth
# are present on this machine.
ConstraintInitializer unixExecs {
set code 1
| | | | | | | | | | | | | | | | | | | | | | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 |
ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
# Test to see if execed commands such as cat, echo, rm and so forth
# are present on this machine.
ConstraintInitializer unixExecs {
set code 1
if {$::tcl_platform(platform) eq "macintosh"} {
set code 0
}
if {$::tcl_platform(platform) eq "windows"} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
}]} {
set code 0
} elseif {
[catch {exec cat $file}] ||
[catch {exec echo hello}] ||
[catch {exec sh -c echo hello}] ||
[catch {exec wc $file}] ||
[catch {exec sleep 1}] ||
[catch {exec echo abc > $file}] ||
[catch {exec chmod 644 $file}] ||
[catch {exec rm $file}] ||
[llength [auto_execok mkdir]] == 0 ||
[llength [auto_execok fgrep]] == 0 ||
[llength [auto_execok grep]] == 0 ||
[llength [auto_execok ps]] == 0
} {
set code 0
}
removeFile $file
}
set code
}
ConstraintInitializer stdio {
variable fullutf
set code 0
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
"missing value for option [lindex $args 0]"
exit 1
}
}
# Call the hook
catch {
| | | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 |
"missing value for option [lindex $args 0]"
exit 1
}
}
# Call the hook
catch {
array set flag $flagArray
processCmdLineArgsHook [array get flag]
}
return
}
# tcltest::ProcessCmdLineArgs --
#
# This procedure must be run after constraint initialization is
|
| ︙ | ︙ | |||
1631 1632 1633 1634 1635 1636 1637 |
1 {
# Only the string to be printed is specified
append outData [lindex $args 0]\n
return
# return [Puts [lindex $args 0]]
}
2 {
| | | | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
1 {
# Only the string to be printed is specified
append outData [lindex $args 0]\n
return
# return [Puts [lindex $args 0]]
}
2 {
# Either -nonewline or channel has been specified
if {[lindex $args 0] eq "-nonewline"} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
} else {
set channel [lindex $args 0]
set newline \n
}
}
3 {
if {[lindex $args 0] eq "-nonewline"} {
# Both -nonewline and channel are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
set newline ""
}
}
}
|
| ︙ | ︙ | |||
1724 1725 1726 1727 1728 1729 1730 |
#
# Side effects:
# None.
proc tcltest::CompareStrings {actual expected mode} {
variable CustomMatch
if {![info exists CustomMatch($mode)]} {
| | | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 |
#
# Side effects:
# None.
proc tcltest::CompareStrings {actual expected mode} {
variable CustomMatch
if {![info exists CustomMatch($mode)]} {
return -code error "No matching command registered for `-match $mode'"
}
set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
if {[catch {expr {$match && $match}} result]} {
return -code error "Invalid result from `-match $mode' command: $result"
}
return $match
}
|
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 |
# separated strings as it throws away the whitespace which maybe
# important so we have to do it all by hand.
set result {}
set token ""
while {[string length $argList]} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 |
# separated strings as it throws away the whitespace which maybe
# important so we have to do it all by hand.
set result {}
set token ""
while {[string length $argList]} {
# Look for the next word containing a quote: " { }
if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
$argList all]} {
# Get the text leading up to this word, but not including
# this word, from the argList.
set text [string range $argList 0 \
[expr {[lindex $all 0] - 1}]]
# Get the word with the quote
set word [string range $argList \
[lindex $all 0] [lindex $all 1]]
# Remove all text up to and including the word from the
# argList.
set argList [string range $argList \
[expr {[lindex $all 1] + 1}] end]
} else {
# Take everything up to the end of the argList.
set text $argList
set word {}
set argList {}
}
if {$token ne {}} {
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
# add the text and the current word to this token.
append token $text $word
} else {
# Add the text to the result. There is no need to parse
# the text because it couldn't be a part of any multi-word
# token. Then start a new multi-word token with the word
# because we need to pass this token to the Tcl parser to
# check for balancing quotes
append result $text
set token $word
}
if { [catch {llength $token} length] == 0 && $length == 1} {
# The token is a valid list so add it to the result.
# lappend result [string trim $token]
append result \{$token\}
set token {}
}
}
# If the last token has not been added to the list then there
# is a problem.
if { [string length $token] } {
error "incomplete token \"$token\""
}
return $result
}
# tcltest::test --
|
| ︙ | ︙ | |||
1906 1907 1908 1909 1910 1911 1912 | # previously registered by a call to [customMatch]. # The strings exact, glob, and regexp are preregistered # by the tcltest package. Default value is exact. # # Arguments: # name - Name of test, in the form foo-1.2. # description - Short textual description of the test, to | | | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 | # previously registered by a call to [customMatch]. # The strings exact, glob, and regexp are preregistered # by the tcltest package. Default value is exact. # # Arguments: # name - Name of test, in the form foo-1.2. # description - Short textual description of the test, to # help humans understand what it does. # # Results: # None. # # Side effects: # Just about anything is possible depending on the test. # |
| ︙ | ︙ | |||
2001 2002 2003 2004 2005 2006 2007 |
must be $values"
}
# Replace symbolic valies supplied for -returnCodes
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
| | | | | | 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 |
must be $values"
}
# Replace symbolic valies supplied for -returnCodes
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
# errorCode without returnCode 1 is meaningless
if {$errorCode ne "*" && 1 ni $returnCodes} {
set returnCodes 1
}
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
|
| ︙ | ︙ | |||
2087 2088 2089 2090 2091 2092 2093 |
# check if the return code matched the expected return code
set codeFailure 0
if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
set errorCodeFailure 0
if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
| | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 |
# check if the return code matched the expected return code
set codeFailure 0
if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
set errorCodeFailure 0
if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
![string match $errorCode $errorCodeRes(body)]} {
set errorCodeFailure 1
}
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 |
set errorFailure 1
}
}
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {!$processTest} {
| | | 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 |
set errorFailure 1
}
}
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {!$processTest} {
set scriptFailure 0
} elseif {$setupFailure || $codeFailure} {
set scriptFailure 0
} elseif {[set scriptCompare [catch {
CompareStrings $actualAnswer $result $match
} scriptMatch]] == 0} {
set scriptFailure [expr {!$scriptMatch}]
} else {
|
| ︙ | ︙ | |||
2406 2407 2408 2409 2410 2411 2412 |
return 1
}
} else {
# "constraints" argument exists;
# make sure that the constraints are satisfied.
set doTest 0
| | | 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 |
return 1
}
} else {
# "constraints" argument exists;
# make sure that the constraints are satisfied.
set doTest 0
set constraints [string trim $constraints]
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel #0 [list expr $constraints]]}
} elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
# something like {a || b} should be turned into
# $testConstraints(a) || $testConstraints(b).
regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
|
| ︙ | ︙ | |||
2915 2916 2917 2918 2919 2920 2921 |
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
if {[catch {
incr numTestFiles
| | | 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 |
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
if {[catch {
incr numTestFiles
uplevel 1 [list ::source -encoding utf-8 $file]
} msg]} {
puts [outputChannel] "Test file error: $msg"
# append the name of the test to a list to be reported
# later
lappend testFileFailures $file
}
if {$numTests(Failed) > 0} {
|
| ︙ | ︙ | |||
3000 3001 3002 3003 3004 3005 3006 |
# Checking for subdirectories in which to run tests
foreach directory [GetMatchingDirectories [testsDirectory]] {
set dir [file tail $directory]
puts [outputChannel] [string repeat ~ 44]
puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
| | | 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 |
# Checking for subdirectories in which to run tests
foreach directory [GetMatchingDirectories [testsDirectory]] {
set dir [file tail $directory]
puts [outputChannel] [string repeat ~ 44]
puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
uplevel 1 [list ::source -encoding utf-8 [file join $directory all.tcl]]
set endTime [eval $timeCmd]
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
return [expr {[info exists testFileFailures] || [info exists failFilesSet]}]
|
| ︙ | ︙ | |||
3334 3335 3336 3337 3338 3339 3340 | # # Results: # result fom encoding # # Side effects: # None | | | 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 |
#
# Results:
# result fom encoding
#
# Side effects:
# None
if {![package vsatisfies [package provide Tcl] 9.0-]} {
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
}
# tcltest::OpenFiles --
#
|
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
# respect to the existing paths, but also between themselves. Otherwise we
# can still add bogus paths, by specifying them in a single call. This
# makes the use of the new paths simpler as well, a trivial assignment of
# the collected paths to the official state var.
set newpaths $paths
foreach p $args {
| | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
# respect to the existing paths, but also between themselves. Otherwise we
# can still add bogus paths, by specifying them in a single call. This
# makes the use of the new paths simpler as well, a trivial assignment of
# the collected paths to the official state var.
set newpaths $paths
foreach p $args {
if {($p eq "") || ($p in $newpaths)} {
# Ignore any path which is empty or already on the list.
continue
}
# Search for paths which are subdirectories of the new one. If there
# are any then the new path violates the restriction about ancestors.
set pos [lsearch -glob $newpaths ${p}/*]
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
# Note that we're using [::list], not [list] because [list] means
# something other than [::list] in this namespace.
roots [::list \
[file dirname [info library]] \
[file join [file dirname [file dirname $exe]] lib] \
]
| < < < < < | | | | | | | 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 |
# Note that we're using [::list], not [list] because [list] means
# something other than [::list] in this namespace.
roots [::list \
[file dirname [info library]] \
[file join [file dirname [file dirname $exe]] lib] \
]
for {set n $minor} {$n >= 0} {incr n -1} {
foreach ev [::list \
TCL${major}.${n}_TM_PATH \
TCL${major}_${n}_TM_PATH \
] {
if {![info exists env($ev)]} continue
foreach p [split $env($ev) $::tcl_platform(pathSeparator)] {
# Paths relative to unresolvable home dirs are ignored
if {![catch {file tildeexpand $p} expanded_path]} {
path add $expanded_path
}
}
}
}
return
}
# ::tcl::tm::roots --
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/Bissau.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Bissau) {
{-9223372036854775808 -3740 0 LMT}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Bissau) {
{-9223372036854775808 -3740 0 LMT}
{-1830380400 -3600 0 -0100}
{157770000 0 0 GMT}
}
|
Changes to library/tzdata/Africa/Casablanca.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Casablanca) {
{-9223372036854775808 -1820 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Casablanca) {
{-9223372036854775808 -1820 0 LMT}
{-1773012580 0 0 +0000}
{-956361600 3600 1 +0100}
{-950490000 0 0 +0000}
{-942019200 3600 1 +0100}
{-761187600 0 0 +0000}
{-617241600 3600 1 +0100}
{-605149200 0 0 +0000}
{-81432000 3600 1 +0100}
{-71110800 0 0 +0000}
{141264000 3600 1 +0100}
{147222000 0 0 +0000}
{199756800 3600 1 +0100}
{207702000 0 0 +0000}
{231292800 3600 1 +0100}
{244249200 0 0 +0000}
{265507200 3600 1 +0100}
{271033200 0 0 +0000}
{448243200 3600 0 +0100}
{504918000 0 0 +0000}
{1212278400 3600 1 +0100}
{1220223600 0 0 +0000}
{1243814400 3600 1 +0100}
{1250809200 0 0 +0000}
{1272758400 3600 1 +0100}
{1281222000 0 0 +0000}
{1301788800 3600 1 +0100}
{1312066800 0 0 +0000}
{1335664800 3600 1 +0100}
{1342749600 0 0 +0000}
{1345428000 3600 1 +0100}
{1348970400 0 0 +0000}
{1367114400 3600 1 +0100}
{1373162400 0 0 +0000}
{1376100000 3600 1 +0100}
{1382839200 0 0 +0000}
{1396144800 3600 1 +0100}
{1403920800 0 0 +0000}
{1406944800 3600 1 +0100}
{1414288800 0 0 +0000}
{1427594400 3600 1 +0100}
{1434247200 0 0 +0000}
{1437271200 3600 1 +0100}
{1445738400 0 0 +0000}
{1459044000 3600 1 +0100}
{1465092000 0 0 +0000}
{1468116000 3600 1 +0100}
{1477792800 0 0 +0000}
{1490493600 3600 1 +0100}
{1495332000 0 0 +0000}
{1498960800 3600 1 +0100}
{1509242400 0 0 +0000}
{1521943200 3600 1 +0100}
{1526176800 0 0 +0000}
{1529200800 3600 1 +0100}
{1540695600 3600 0 +0100}
{1557021600 0 1 +0000}
{1560045600 3600 0 +0100}
{1587261600 0 1 +0000}
{1590890400 3600 0 +0100}
{1618106400 0 1 +0000}
{1621130400 3600 0 +0100}
{1648346400 0 1 +0000}
{1651975200 3600 0 +0100}
{1679191200 0 1 +0000}
{1682215200 3600 0 +0100}
{1710036000 0 1 +0000}
{1713060000 3600 0 +0100}
{1740276000 0 1 +0000}
{1743904800 3600 0 +0100}
{1771120800 0 1 +0000}
{1774144800 3600 0 +0100}
{1801965600 0 1 +0000}
{1804989600 3600 0 +0100}
{1832205600 0 1 +0000}
{1835834400 3600 0 +0100}
{1863050400 0 1 +0000}
{1866074400 3600 0 +0100}
{1893290400 0 1 +0000}
{1896919200 3600 0 +0100}
{1924135200 0 1 +0000}
{1927159200 3600 0 +0100}
{1954980000 0 1 +0000}
{1958004000 3600 0 +0100}
{1985220000 0 1 +0000}
{1988848800 3600 0 +0100}
{2016064800 0 1 +0000}
{2019088800 3600 0 +0100}
{2046304800 0 1 +0000}
{2049933600 3600 0 +0100}
{2077149600 0 1 +0000}
{2080778400 3600 0 +0100}
{2107994400 0 1 +0000}
{2111018400 3600 0 +0100}
{2138234400 0 1 +0000}
{2141863200 3600 0 +0100}
{2169079200 0 1 +0000}
{2172103200 3600 0 +0100}
{2199924000 0 1 +0000}
{2202948000 3600 0 +0100}
{2230164000 0 1 +0000}
{2233792800 3600 0 +0100}
{2261008800 0 1 +0000}
{2264032800 3600 0 +0100}
{2291248800 0 1 +0000}
{2294877600 3600 0 +0100}
{2322093600 0 1 +0000}
{2325722400 3600 0 +0100}
{2352938400 0 1 +0000}
{2355962400 3600 0 +0100}
{2383178400 0 1 +0000}
{2386807200 3600 0 +0100}
{2414023200 0 1 +0000}
{2417047200 3600 0 +0100}
{2444868000 0 1 +0000}
{2447892000 3600 0 +0100}
{2475108000 0 1 +0000}
{2478736800 3600 0 +0100}
{2505952800 0 1 +0000}
{2508976800 3600 0 +0100}
{2536192800 0 1 +0000}
{2539821600 3600 0 +0100}
{2567037600 0 1 +0000}
{2570666400 3600 0 +0100}
{2597882400 0 1 +0000}
{2600906400 3600 0 +0100}
{2628122400 0 1 +0000}
{2631751200 3600 0 +0100}
{2658967200 0 1 +0000}
{2661991200 3600 0 +0100}
{2689812000 0 1 +0000}
{2692836000 3600 0 +0100}
{2720052000 0 1 +0000}
{2723680800 3600 0 +0100}
{2750896800 0 1 +0000}
{2753920800 3600 0 +0100}
{2781136800 0 1 +0000}
{2784765600 3600 0 +0100}
{2811981600 0 1 +0000}
{2815610400 3600 0 +0100}
{2842826400 0 1 +0000}
{2845850400 3600 0 +0100}
{2873066400 0 1 +0000}
{2876695200 3600 0 +0100}
{2903911200 0 1 +0000}
{2906935200 3600 0 +0100}
{2934756000 0 1 +0000}
{2937780000 3600 0 +0100}
{2964996000 0 1 +0000}
{2968624800 3600 0 +0100}
{2995840800 0 1 +0000}
{2998864800 3600 0 +0100}
{3026080800 0 1 +0000}
{3029709600 3600 0 +0100}
{3056925600 0 1 +0000}
{3060554400 3600 0 +0100}
{3087770400 0 1 +0000}
{3090794400 3600 0 +0100}
{3118010400 0 1 +0000}
{3121639200 3600 0 +0100}
{3148855200 0 1 +0000}
{3151879200 3600 0 +0100}
{3179700000 0 1 +0000}
{3182724000 3600 0 +0100}
{3209940000 0 1 +0000}
{3213568800 3600 0 +0100}
{3240784800 0 1 +0000}
{3243808800 3600 0 +0100}
{3271024800 0 1 +0000}
{3274653600 3600 0 +0100}
{3301869600 0 1 +0000}
{3305498400 3600 0 +0100}
{3332714400 0 1 +0000}
{3335738400 3600 0 +0100}
{3362954400 0 1 +0000}
{3366583200 3600 0 +0100}
{3393799200 0 1 +0000}
{3396823200 3600 0 +0100}
{3424644000 0 1 +0000}
{3427668000 3600 0 +0100}
{3454884000 0 1 +0000}
{3458512800 3600 0 +0100}
{3485728800 0 1 +0000}
{3488752800 3600 0 +0100}
{3515968800 0 1 +0000}
{3519597600 3600 0 +0100}
{3546813600 0 1 +0000}
{3549837600 3600 0 +0100}
{3577658400 0 1 +0000}
{3580682400 3600 0 +0100}
{3607898400 0 1 +0000}
{3611527200 3600 0 +0100}
{3638743200 0 1 +0000}
{3641767200 3600 0 +0100}
{3669588000 0 1 +0000}
{3672612000 3600 0 +0100}
{3699828000 0 1 +0000}
{3703456800 3600 0 +0100}
}
|
Changes to library/tzdata/Africa/El_Aaiun.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/El_Aaiun) {
{-9223372036854775808 -3168 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/El_Aaiun) {
{-9223372036854775808 -3168 0 LMT}
{-1136070432 -3600 0 -0100}
{198291600 0 0 +0000}
{199756800 3600 1 +0100}
{207702000 0 0 +0000}
{231292800 3600 1 +0100}
{244249200 0 0 +0000}
{265507200 3600 1 +0100}
{271033200 0 0 +0000}
{1212278400 3600 1 +0100}
{1220223600 0 0 +0000}
{1243814400 3600 1 +0100}
{1250809200 0 0 +0000}
{1272758400 3600 1 +0100}
{1281222000 0 0 +0000}
{1301788800 3600 1 +0100}
{1312066800 0 0 +0000}
{1335664800 3600 1 +0100}
{1342749600 0 0 +0000}
{1345428000 3600 1 +0100}
{1348970400 0 0 +0000}
{1367114400 3600 1 +0100}
{1373162400 0 0 +0000}
{1376100000 3600 1 +0100}
{1382839200 0 0 +0000}
{1396144800 3600 1 +0100}
{1403920800 0 0 +0000}
{1406944800 3600 1 +0100}
{1414288800 0 0 +0000}
{1427594400 3600 1 +0100}
{1434247200 0 0 +0000}
{1437271200 3600 1 +0100}
{1445738400 0 0 +0000}
{1459044000 3600 1 +0100}
{1465092000 0 0 +0000}
{1468116000 3600 1 +0100}
{1477792800 0 0 +0000}
{1490493600 3600 1 +0100}
{1495332000 0 0 +0000}
{1498960800 3600 1 +0100}
{1509242400 0 0 +0000}
{1521943200 3600 1 +0100}
{1526176800 0 0 +0000}
{1529200800 3600 1 +0100}
{1540695600 3600 0 +0100}
{1557021600 0 1 +0000}
{1560045600 3600 0 +0100}
{1587261600 0 1 +0000}
{1590890400 3600 0 +0100}
{1618106400 0 1 +0000}
{1621130400 3600 0 +0100}
{1648346400 0 1 +0000}
{1651975200 3600 0 +0100}
{1679191200 0 1 +0000}
{1682215200 3600 0 +0100}
{1710036000 0 1 +0000}
{1713060000 3600 0 +0100}
{1740276000 0 1 +0000}
{1743904800 3600 0 +0100}
{1771120800 0 1 +0000}
{1774144800 3600 0 +0100}
{1801965600 0 1 +0000}
{1804989600 3600 0 +0100}
{1832205600 0 1 +0000}
{1835834400 3600 0 +0100}
{1863050400 0 1 +0000}
{1866074400 3600 0 +0100}
{1893290400 0 1 +0000}
{1896919200 3600 0 +0100}
{1924135200 0 1 +0000}
{1927159200 3600 0 +0100}
{1954980000 0 1 +0000}
{1958004000 3600 0 +0100}
{1985220000 0 1 +0000}
{1988848800 3600 0 +0100}
{2016064800 0 1 +0000}
{2019088800 3600 0 +0100}
{2046304800 0 1 +0000}
{2049933600 3600 0 +0100}
{2077149600 0 1 +0000}
{2080778400 3600 0 +0100}
{2107994400 0 1 +0000}
{2111018400 3600 0 +0100}
{2138234400 0 1 +0000}
{2141863200 3600 0 +0100}
{2169079200 0 1 +0000}
{2172103200 3600 0 +0100}
{2199924000 0 1 +0000}
{2202948000 3600 0 +0100}
{2230164000 0 1 +0000}
{2233792800 3600 0 +0100}
{2261008800 0 1 +0000}
{2264032800 3600 0 +0100}
{2291248800 0 1 +0000}
{2294877600 3600 0 +0100}
{2322093600 0 1 +0000}
{2325722400 3600 0 +0100}
{2352938400 0 1 +0000}
{2355962400 3600 0 +0100}
{2383178400 0 1 +0000}
{2386807200 3600 0 +0100}
{2414023200 0 1 +0000}
{2417047200 3600 0 +0100}
{2444868000 0 1 +0000}
{2447892000 3600 0 +0100}
{2475108000 0 1 +0000}
{2478736800 3600 0 +0100}
{2505952800 0 1 +0000}
{2508976800 3600 0 +0100}
{2536192800 0 1 +0000}
{2539821600 3600 0 +0100}
{2567037600 0 1 +0000}
{2570666400 3600 0 +0100}
{2597882400 0 1 +0000}
{2600906400 3600 0 +0100}
{2628122400 0 1 +0000}
{2631751200 3600 0 +0100}
{2658967200 0 1 +0000}
{2661991200 3600 0 +0100}
{2689812000 0 1 +0000}
{2692836000 3600 0 +0100}
{2720052000 0 1 +0000}
{2723680800 3600 0 +0100}
{2750896800 0 1 +0000}
{2753920800 3600 0 +0100}
{2781136800 0 1 +0000}
{2784765600 3600 0 +0100}
{2811981600 0 1 +0000}
{2815610400 3600 0 +0100}
{2842826400 0 1 +0000}
{2845850400 3600 0 +0100}
{2873066400 0 1 +0000}
{2876695200 3600 0 +0100}
{2903911200 0 1 +0000}
{2906935200 3600 0 +0100}
{2934756000 0 1 +0000}
{2937780000 3600 0 +0100}
{2964996000 0 1 +0000}
{2968624800 3600 0 +0100}
{2995840800 0 1 +0000}
{2998864800 3600 0 +0100}
{3026080800 0 1 +0000}
{3029709600 3600 0 +0100}
{3056925600 0 1 +0000}
{3060554400 3600 0 +0100}
{3087770400 0 1 +0000}
{3090794400 3600 0 +0100}
{3118010400 0 1 +0000}
{3121639200 3600 0 +0100}
{3148855200 0 1 +0000}
{3151879200 3600 0 +0100}
{3179700000 0 1 +0000}
{3182724000 3600 0 +0100}
{3209940000 0 1 +0000}
{3213568800 3600 0 +0100}
{3240784800 0 1 +0000}
{3243808800 3600 0 +0100}
{3271024800 0 1 +0000}
{3274653600 3600 0 +0100}
{3301869600 0 1 +0000}
{3305498400 3600 0 +0100}
{3332714400 0 1 +0000}
{3335738400 3600 0 +0100}
{3362954400 0 1 +0000}
{3366583200 3600 0 +0100}
{3393799200 0 1 +0000}
{3396823200 3600 0 +0100}
{3424644000 0 1 +0000}
{3427668000 3600 0 +0100}
{3454884000 0 1 +0000}
{3458512800 3600 0 +0100}
{3485728800 0 1 +0000}
{3488752800 3600 0 +0100}
{3515968800 0 1 +0000}
{3519597600 3600 0 +0100}
{3546813600 0 1 +0000}
{3549837600 3600 0 +0100}
{3577658400 0 1 +0000}
{3580682400 3600 0 +0100}
{3607898400 0 1 +0000}
{3611527200 3600 0 +0100}
{3638743200 0 1 +0000}
{3641767200 3600 0 +0100}
{3669588000 0 1 +0000}
{3672612000 3600 0 +0100}
{3699828000 0 1 +0000}
{3703456800 3600 0 +0100}
}
|
Changes to library/tzdata/Africa/Maputo.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Maputo) {
| | | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Maputo) {
{-9223372036854775808 7818 0 LMT}
{-1924999818 7200 0 CAT}
}
|
Changes to library/tzdata/America/Araguaina.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Araguaina) {
{-9223372036854775808 -11568 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Araguaina) {
{-9223372036854775808 -11568 0 LMT}
{-1767214032 -10800 0 -0300}
{-1206957600 -7200 1 -0200}
{-1191362400 -10800 0 -0300}
{-1175374800 -7200 1 -0200}
{-1159826400 -10800 0 -0300}
{-633819600 -7200 1 -0200}
{-622069200 -10800 0 -0300}
{-602283600 -7200 1 -0200}
{-591832800 -10800 0 -0300}
{-570747600 -7200 1 -0200}
{-560210400 -10800 0 -0300}
{-539125200 -7200 1 -0200}
{-531352800 -10800 0 -0300}
{-191365200 -7200 1 -0200}
{-184197600 -10800 0 -0300}
{-155163600 -7200 1 -0200}
{-150069600 -10800 0 -0300}
{-128898000 -7200 1 -0200}
{-121125600 -10800 0 -0300}
{-99954000 -7200 1 -0200}
{-89589600 -10800 0 -0300}
{-68418000 -7200 1 -0200}
{-57967200 -10800 0 -0300}
{499748400 -7200 1 -0200}
{511236000 -10800 0 -0300}
{530593200 -7200 1 -0200}
{540266400 -10800 0 -0300}
{562129200 -7200 1 -0200}
{571197600 -10800 0 -0300}
{592974000 -7200 1 -0200}
{602042400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{634701600 -10800 0 -0300}
{653536800 -10800 0 -0300}
{811047600 -10800 0 -0300}
{813726000 -7200 1 -0200}
{824004000 -10800 0 -0300}
{844570800 -7200 1 -0200}
{856058400 -10800 0 -0300}
{876106800 -7200 1 -0200}
{888717600 -10800 0 -0300}
{908074800 -7200 1 -0200}
{919562400 -10800 0 -0300}
{938919600 -7200 1 -0200}
{951616800 -10800 0 -0300}
{970974000 -7200 1 -0200}
{982461600 -10800 0 -0300}
{1003028400 -7200 1 -0200}
{1013911200 -10800 0 -0300}
{1036292400 -7200 1 -0200}
{1045360800 -10800 0 -0300}
{1064368800 -10800 0 -0300}
{1350788400 -7200 0 -0200}
{1361066400 -10800 0 -0300}
{1378000800 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Buenos_Aires.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Buenos_Aires) {
{-9223372036854775808 -14028 0 LMT}
{-2372097972 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Buenos_Aires) {
{-9223372036854775808 -14028 0 LMT}
{-2372097972 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -10800 0 -0300}
{687927600 -7200 1 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224385200 -7200 1 -0200}
{1237082400 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Catamarca.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Catamarca) {
{-9223372036854775808 -15788 0 LMT}
{-2372096212 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Catamarca) {
{-9223372036854775808 -15788 0 LMT}
{-2372096212 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -14400 0 -0400}
{687931200 -7200 0 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1086058800 -14400 0 -0400}
{1087704000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Cordoba.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Cordoba) {
{-9223372036854775808 -15408 0 LMT}
{-2372096592 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Cordoba) {
{-9223372036854775808 -15408 0 LMT}
{-2372096592 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -14400 0 -0400}
{687931200 -7200 0 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224385200 -7200 1 -0200}
{1237082400 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Jujuy.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Jujuy) {
{-9223372036854775808 -15672 0 LMT}
{-2372096328 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Jujuy) {
{-9223372036854775808 -15672 0 LMT}
{-2372096328 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -14400 0 -0400}
{657086400 -10800 1 -0300}
{669178800 -14400 0 -0400}
{686721600 -7200 1 -0200}
{694231200 -7200 0 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/La_Rioja.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/La_Rioja) {
{-9223372036854775808 -16044 0 LMT}
{-2372095956 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/La_Rioja) {
{-9223372036854775808 -16044 0 LMT}
{-2372095956 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667792800 -14400 0 -0400}
{673588800 -10800 0 -0300}
{687927600 -7200 1 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1086058800 -14400 0 -0400}
{1087704000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Mendoza.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Mendoza) {
{-9223372036854775808 -16516 0 LMT}
{-2372095484 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Mendoza) {
{-9223372036854775808 -16516 0 LMT}
{-2372095484 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -14400 0 -0400}
{655963200 -10800 1 -0300}
{667796400 -14400 0 -0400}
{687499200 -10800 1 -0300}
{699418800 -14400 0 -0400}
{719380800 -7200 0 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1085281200 -14400 0 -0400}
{1096171200 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Rio_Gallegos.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Rio_Gallegos) {
{-9223372036854775808 -16612 0 LMT}
{-2372095388 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Rio_Gallegos) {
{-9223372036854775808 -16612 0 LMT}
{-2372095388 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -10800 0 -0300}
{687927600 -7200 1 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1086058800 -14400 0 -0400}
{1087704000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Salta.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Salta) {
{-9223372036854775808 -15700 0 LMT}
{-2372096300 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Salta) {
{-9223372036854775808 -15700 0 LMT}
{-2372096300 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -14400 0 -0400}
{687931200 -7200 0 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/San_Juan.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Juan) {
{-9223372036854775808 -16444 0 LMT}
{-2372095556 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Juan) {
{-9223372036854775808 -16444 0 LMT}
{-2372095556 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667792800 -14400 0 -0400}
{673588800 -10800 0 -0300}
{687927600 -7200 1 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1085972400 -14400 0 -0400}
{1090728000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/San_Luis.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Luis) {
{-9223372036854775808 -15924 0 LMT}
{-2372096076 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/San_Luis) {
{-9223372036854775808 -15924 0 LMT}
{-2372096076 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{631159200 -7200 1 -0200}
{637380000 -14400 0 -0400}
{655963200 -10800 1 -0300}
{667796400 -14400 0 -0400}
{675748800 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952052400 -10800 0 -0300}
{1085972400 -14400 0 -0400}
{1090728000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1200880800 -10800 0 -0300}
{1205031600 -14400 0 -0400}
{1223784000 -10800 1 -0300}
{1236481200 -14400 0 -0400}
{1255233600 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Tucuman.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Tucuman) {
{-9223372036854775808 -15652 0 LMT}
{-2372096348 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Tucuman) {
{-9223372036854775808 -15652 0 LMT}
{-2372096348 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -14400 0 -0400}
{687931200 -7200 0 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1086058800 -14400 0 -0400}
{1087099200 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224385200 -7200 1 -0200}
{1237082400 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Argentina/Ushuaia.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Ushuaia) {
{-9223372036854775808 -16392 0 LMT}
{-2372095608 -15408 0 CMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Argentina/Ushuaia) {
{-9223372036854775808 -16392 0 LMT}
{-2372095608 -15408 0 CMT}
{-1567453392 -14400 0 -0400}
{-1233432000 -10800 0 -0300}
{-1222981200 -14400 0 -0400}
{-1205956800 -10800 1 -0300}
{-1194037200 -14400 0 -0400}
{-1172865600 -10800 1 -0300}
{-1162501200 -14400 0 -0400}
{-1141329600 -10800 1 -0300}
{-1130965200 -14400 0 -0400}
{-1109793600 -10800 1 -0300}
{-1099429200 -14400 0 -0400}
{-1078257600 -10800 1 -0300}
{-1067806800 -14400 0 -0400}
{-1046635200 -10800 1 -0300}
{-1036270800 -14400 0 -0400}
{-1015099200 -10800 1 -0300}
{-1004734800 -14400 0 -0400}
{-983563200 -10800 1 -0300}
{-973198800 -14400 0 -0400}
{-952027200 -10800 1 -0300}
{-941576400 -14400 0 -0400}
{-931032000 -10800 1 -0300}
{-900882000 -14400 0 -0400}
{-890337600 -10800 1 -0300}
{-833749200 -14400 0 -0400}
{-827265600 -10800 1 -0300}
{-752274000 -14400 0 -0400}
{-733780800 -10800 1 -0300}
{-197326800 -14400 0 -0400}
{-190843200 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-164491200 -10800 1 -0300}
{-152658000 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{596948400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{636516000 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -10800 0 -0300}
{687927600 -7200 1 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{731469600 -10800 0 -0300}
{938916000 -10800 0 -0300}
{938919600 -10800 1 -0300}
{952056000 -10800 0 -0300}
{1085886000 -14400 0 -0400}
{1087704000 -10800 0 -0300}
{1198983600 -7200 1 -0200}
{1205632800 -10800 0 -0300}
{1224295200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Asuncion.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Asuncion) {
{-9223372036854775808 -13840 0 LMT}
{-2524507760 -13840 0 AMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Asuncion) {
{-9223372036854775808 -13840 0 LMT}
{-2524507760 -13840 0 AMT}
{-1206389360 -14400 0 -0400}
{86760000 -10800 0 -0300}
{134017200 -14400 0 -0400}
{162878400 -14400 0 -0400}
{181368000 -10800 1 -0300}
{194497200 -14400 0 -0400}
{212990400 -10800 1 -0300}
{226033200 -14400 0 -0400}
{244526400 -10800 1 -0300}
{257569200 -14400 0 -0400}
{276062400 -10800 1 -0300}
{291783600 -14400 0 -0400}
{307598400 -10800 1 -0300}
{323406000 -14400 0 -0400}
{339220800 -10800 1 -0300}
{354942000 -14400 0 -0400}
{370756800 -10800 1 -0300}
{386478000 -14400 0 -0400}
{402292800 -10800 1 -0300}
{418014000 -14400 0 -0400}
{433828800 -10800 1 -0300}
{449636400 -14400 0 -0400}
{465451200 -10800 1 -0300}
{481172400 -14400 0 -0400}
{496987200 -10800 1 -0300}
{512708400 -14400 0 -0400}
{528523200 -10800 1 -0300}
{544244400 -14400 0 -0400}
{560059200 -10800 1 -0300}
{575866800 -14400 0 -0400}
{591681600 -10800 1 -0300}
{607402800 -14400 0 -0400}
{625032000 -10800 1 -0300}
{638938800 -14400 0 -0400}
{654753600 -10800 1 -0300}
{670474800 -14400 0 -0400}
{686721600 -10800 1 -0300}
{699418800 -14400 0 -0400}
{718257600 -10800 1 -0300}
{733546800 -14400 0 -0400}
{749448000 -10800 1 -0300}
{762318000 -14400 0 -0400}
{780984000 -10800 1 -0300}
{793767600 -14400 0 -0400}
{812520000 -10800 1 -0300}
{825649200 -14400 0 -0400}
{844574400 -10800 1 -0300}
{856666800 -14400 0 -0400}
{876024000 -10800 1 -0300}
{888721200 -14400 0 -0400}
{907473600 -10800 1 -0300}
{920775600 -14400 0 -0400}
{938923200 -10800 1 -0300}
{952225200 -14400 0 -0400}
{970372800 -10800 1 -0300}
{983674800 -14400 0 -0400}
{1002427200 -10800 1 -0300}
{1018148400 -14400 0 -0400}
{1030852800 -10800 1 -0300}
{1049598000 -14400 0 -0400}
{1062907200 -10800 1 -0300}
{1081047600 -14400 0 -0400}
{1097985600 -10800 1 -0300}
{1110682800 -14400 0 -0400}
{1129435200 -10800 1 -0300}
{1142132400 -14400 0 -0400}
{1160884800 -10800 1 -0300}
{1173582000 -14400 0 -0400}
{1192939200 -10800 1 -0300}
{1205031600 -14400 0 -0400}
{1224388800 -10800 1 -0300}
{1236481200 -14400 0 -0400}
{1255838400 -10800 1 -0300}
{1270954800 -14400 0 -0400}
{1286078400 -10800 1 -0300}
{1302404400 -14400 0 -0400}
{1317528000 -10800 1 -0300}
{1333854000 -14400 0 -0400}
{1349582400 -10800 1 -0300}
{1364094000 -14400 0 -0400}
{1381032000 -10800 1 -0300}
{1395543600 -14400 0 -0400}
{1412481600 -10800 1 -0300}
{1426993200 -14400 0 -0400}
{1443931200 -10800 1 -0300}
{1459047600 -14400 0 -0400}
{1475380800 -10800 1 -0300}
{1490497200 -14400 0 -0400}
{1506830400 -10800 1 -0300}
{1521946800 -14400 0 -0400}
{1538884800 -10800 1 -0300}
{1553396400 -14400 0 -0400}
{1570334400 -10800 1 -0300}
{1584846000 -14400 0 -0400}
{1601784000 -10800 1 -0300}
{1616900400 -14400 0 -0400}
{1633233600 -10800 1 -0300}
{1648350000 -14400 0 -0400}
{1664683200 -10800 1 -0300}
{1679799600 -14400 0 -0400}
{1696132800 -10800 1 -0300}
{1711249200 -14400 0 -0400}
{1728187200 -10800 1 -0300}
{1742698800 -14400 0 -0400}
{1759636800 -10800 1 -0300}
{1774148400 -14400 0 -0400}
{1791086400 -10800 1 -0300}
{1806202800 -14400 0 -0400}
{1822536000 -10800 1 -0300}
{1837652400 -14400 0 -0400}
{1853985600 -10800 1 -0300}
{1869102000 -14400 0 -0400}
{1886040000 -10800 1 -0300}
{1900551600 -14400 0 -0400}
{1917489600 -10800 1 -0300}
{1932001200 -14400 0 -0400}
{1948939200 -10800 1 -0300}
{1964055600 -14400 0 -0400}
{1980388800 -10800 1 -0300}
{1995505200 -14400 0 -0400}
{2011838400 -10800 1 -0300}
{2026954800 -14400 0 -0400}
{2043288000 -10800 1 -0300}
{2058404400 -14400 0 -0400}
{2075342400 -10800 1 -0300}
{2089854000 -14400 0 -0400}
{2106792000 -10800 1 -0300}
{2121303600 -14400 0 -0400}
{2138241600 -10800 1 -0300}
{2153358000 -14400 0 -0400}
{2169691200 -10800 1 -0300}
{2184807600 -14400 0 -0400}
{2201140800 -10800 1 -0300}
{2216257200 -14400 0 -0400}
{2233195200 -10800 1 -0300}
{2247706800 -14400 0 -0400}
{2264644800 -10800 1 -0300}
{2279156400 -14400 0 -0400}
{2296094400 -10800 1 -0300}
{2310606000 -14400 0 -0400}
{2327544000 -10800 1 -0300}
{2342660400 -14400 0 -0400}
{2358993600 -10800 1 -0300}
{2374110000 -14400 0 -0400}
{2390443200 -10800 1 -0300}
{2405559600 -14400 0 -0400}
{2422497600 -10800 1 -0300}
{2437009200 -14400 0 -0400}
{2453947200 -10800 1 -0300}
{2468458800 -14400 0 -0400}
{2485396800 -10800 1 -0300}
{2500513200 -14400 0 -0400}
{2516846400 -10800 1 -0300}
{2531962800 -14400 0 -0400}
{2548296000 -10800 1 -0300}
{2563412400 -14400 0 -0400}
{2579745600 -10800 1 -0300}
{2594862000 -14400 0 -0400}
{2611800000 -10800 1 -0300}
{2626311600 -14400 0 -0400}
{2643249600 -10800 1 -0300}
{2657761200 -14400 0 -0400}
{2674699200 -10800 1 -0300}
{2689815600 -14400 0 -0400}
{2706148800 -10800 1 -0300}
{2721265200 -14400 0 -0400}
{2737598400 -10800 1 -0300}
{2752714800 -14400 0 -0400}
{2769652800 -10800 1 -0300}
{2784164400 -14400 0 -0400}
{2801102400 -10800 1 -0300}
{2815614000 -14400 0 -0400}
{2832552000 -10800 1 -0300}
{2847668400 -14400 0 -0400}
{2864001600 -10800 1 -0300}
{2879118000 -14400 0 -0400}
{2895451200 -10800 1 -0300}
{2910567600 -14400 0 -0400}
{2926900800 -10800 1 -0300}
{2942017200 -14400 0 -0400}
{2958955200 -10800 1 -0300}
{2973466800 -14400 0 -0400}
{2990404800 -10800 1 -0300}
{3004916400 -14400 0 -0400}
{3021854400 -10800 1 -0300}
{3036970800 -14400 0 -0400}
{3053304000 -10800 1 -0300}
{3068420400 -14400 0 -0400}
{3084753600 -10800 1 -0300}
{3099870000 -14400 0 -0400}
{3116808000 -10800 1 -0300}
{3131319600 -14400 0 -0400}
{3148257600 -10800 1 -0300}
{3162769200 -14400 0 -0400}
{3179707200 -10800 1 -0300}
{3194218800 -14400 0 -0400}
{3211156800 -10800 1 -0300}
{3226273200 -14400 0 -0400}
{3242606400 -10800 1 -0300}
{3257722800 -14400 0 -0400}
{3274056000 -10800 1 -0300}
{3289172400 -14400 0 -0400}
{3306110400 -10800 1 -0300}
{3320622000 -14400 0 -0400}
{3337560000 -10800 1 -0300}
{3352071600 -14400 0 -0400}
{3369009600 -10800 1 -0300}
{3384126000 -14400 0 -0400}
{3400459200 -10800 1 -0300}
{3415575600 -14400 0 -0400}
{3431908800 -10800 1 -0300}
{3447025200 -14400 0 -0400}
{3463358400 -10800 1 -0300}
{3478474800 -14400 0 -0400}
{3495412800 -10800 1 -0300}
{3509924400 -14400 0 -0400}
{3526862400 -10800 1 -0300}
{3541374000 -14400 0 -0400}
{3558312000 -10800 1 -0300}
{3573428400 -14400 0 -0400}
{3589761600 -10800 1 -0300}
{3604878000 -14400 0 -0400}
{3621211200 -10800 1 -0300}
{3636327600 -14400 0 -0400}
{3653265600 -10800 1 -0300}
{3667777200 -14400 0 -0400}
{3684715200 -10800 1 -0300}
{3699226800 -14400 0 -0400}
{3716164800 -10800 1 -0300}
{3731281200 -14400 0 -0400}
{3747614400 -10800 1 -0300}
{3762730800 -14400 0 -0400}
{3779064000 -10800 1 -0300}
{3794180400 -14400 0 -0400}
{3810513600 -10800 1 -0300}
{3825630000 -14400 0 -0400}
{3842568000 -10800 1 -0300}
{3857079600 -14400 0 -0400}
{3874017600 -10800 1 -0300}
{3888529200 -14400 0 -0400}
{3905467200 -10800 1 -0300}
{3920583600 -14400 0 -0400}
{3936916800 -10800 1 -0300}
{3952033200 -14400 0 -0400}
{3968366400 -10800 1 -0300}
{3983482800 -14400 0 -0400}
{4000420800 -10800 1 -0300}
{4014932400 -14400 0 -0400}
{4031870400 -10800 1 -0300}
{4046382000 -14400 0 -0400}
{4063320000 -10800 1 -0300}
{4077831600 -14400 0 -0400}
{4094769600 -10800 1 -0300}
}
|
Changes to library/tzdata/America/Bahia.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bahia) {
{-9223372036854775808 -9244 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bahia) {
{-9223372036854775808 -9244 0 LMT}
{-1767216356 -10800 0 -0300}
{-1206957600 -7200 1 -0200}
{-1191362400 -10800 0 -0300}
{-1175374800 -7200 1 -0200}
{-1159826400 -10800 0 -0300}
{-633819600 -7200 1 -0200}
{-622069200 -10800 0 -0300}
{-602283600 -7200 1 -0200}
{-591832800 -10800 0 -0300}
{-570747600 -7200 1 -0200}
{-560210400 -10800 0 -0300}
{-539125200 -7200 1 -0200}
{-531352800 -10800 0 -0300}
{-191365200 -7200 1 -0200}
{-184197600 -10800 0 -0300}
{-155163600 -7200 1 -0200}
{-150069600 -10800 0 -0300}
{-128898000 -7200 1 -0200}
{-121125600 -10800 0 -0300}
{-99954000 -7200 1 -0200}
{-89589600 -10800 0 -0300}
{-68418000 -7200 1 -0200}
{-57967200 -10800 0 -0300}
{499748400 -7200 1 -0200}
{511236000 -10800 0 -0300}
{530593200 -7200 1 -0200}
{540266400 -10800 0 -0300}
{562129200 -7200 1 -0200}
{571197600 -10800 0 -0300}
{592974000 -7200 1 -0200}
{602042400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{634701600 -10800 0 -0300}
{656478000 -7200 1 -0200}
{666756000 -10800 0 -0300}
{687927600 -7200 1 -0200}
{697600800 -10800 0 -0300}
{719982000 -7200 1 -0200}
{728445600 -10800 0 -0300}
{750826800 -7200 1 -0200}
{761709600 -10800 0 -0300}
{782276400 -7200 1 -0200}
{793159200 -10800 0 -0300}
{813726000 -7200 1 -0200}
{824004000 -10800 0 -0300}
{844570800 -7200 1 -0200}
{856058400 -10800 0 -0300}
{876106800 -7200 1 -0200}
{888717600 -10800 0 -0300}
{908074800 -7200 1 -0200}
{919562400 -10800 0 -0300}
{938919600 -7200 1 -0200}
{951616800 -10800 0 -0300}
{970974000 -7200 1 -0200}
{982461600 -10800 0 -0300}
{1003028400 -7200 1 -0200}
{1013911200 -10800 0 -0300}
{1036292400 -7200 1 -0200}
{1045360800 -10800 0 -0300}
{1064368800 -10800 0 -0300}
{1318734000 -7200 0 -0200}
{1330221600 -10800 0 -0300}
{1350784800 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Bahia_Banderas.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bahia_Banderas) {
{-9223372036854775808 -25260 0 LMT}
{-1514739600 -25200 0 MST}
| | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bahia_Banderas) {
{-9223372036854775808 -25260 0 LMT}
{-1514739600 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-873828000 -25200 0 MST}
{25200 -25200 0 MST}
{828867600 -21600 1 MDT}
{846403200 -25200 0 MST}
{860317200 -21600 1 MDT}
{877852800 -25200 0 MST}
{891766800 -21600 1 MDT}
{909302400 -25200 0 MST}
{923216400 -21600 1 MDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Belem.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Belem) {
{-9223372036854775808 -11636 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Belem) {
{-9223372036854775808 -11636 0 LMT}
{-1767213964 -10800 0 -0300}
{-1206957600 -7200 1 -0200}
{-1191362400 -10800 0 -0300}
{-1175374800 -7200 1 -0200}
{-1159826400 -10800 0 -0300}
{-633819600 -7200 1 -0200}
{-622069200 -10800 0 -0300}
{-602283600 -7200 1 -0200}
{-591832800 -10800 0 -0300}
{-570747600 -7200 1 -0200}
{-560210400 -10800 0 -0300}
{-539125200 -7200 1 -0200}
{-531352800 -10800 0 -0300}
{-191365200 -7200 1 -0200}
{-184197600 -10800 0 -0300}
{-155163600 -7200 1 -0200}
{-150069600 -10800 0 -0300}
{-128898000 -7200 1 -0200}
{-121125600 -10800 0 -0300}
{-99954000 -7200 1 -0200}
{-89589600 -10800 0 -0300}
{-68418000 -7200 1 -0200}
{-57967200 -10800 0 -0300}
{499748400 -7200 1 -0200}
{511236000 -10800 0 -0300}
{530593200 -7200 1 -0200}
{540266400 -10800 0 -0300}
{562129200 -7200 1 -0200}
{571197600 -10800 0 -0300}
{590032800 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Boa_Vista.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Boa_Vista) {
{-9223372036854775808 -14560 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Boa_Vista) {
{-9223372036854775808 -14560 0 LMT}
{-1767211040 -14400 0 -0400}
{-1206954000 -10800 1 -0300}
{-1191358800 -14400 0 -0400}
{-1175371200 -10800 1 -0300}
{-1159822800 -14400 0 -0400}
{-633816000 -10800 1 -0300}
{-622065600 -14400 0 -0400}
{-602280000 -10800 1 -0300}
{-591829200 -14400 0 -0400}
{-570744000 -10800 1 -0300}
{-560206800 -14400 0 -0400}
{-539121600 -10800 1 -0300}
{-531349200 -14400 0 -0400}
{-191361600 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-155160000 -10800 1 -0300}
{-150066000 -14400 0 -0400}
{-128894400 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-99950400 -10800 1 -0300}
{-89586000 -14400 0 -0400}
{-68414400 -10800 1 -0300}
{-57963600 -14400 0 -0400}
{499752000 -10800 1 -0300}
{511239600 -14400 0 -0400}
{530596800 -10800 1 -0300}
{540270000 -14400 0 -0400}
{562132800 -10800 1 -0300}
{571201200 -14400 0 -0400}
{590036400 -14400 0 -0400}
{938664000 -14400 0 -0400}
{938923200 -10800 1 -0300}
{951620400 -14400 0 -0400}
{970977600 -10800 1 -0300}
{971578800 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Bogota.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bogota) {
{-9223372036854775808 -17776 0 LMT}
{-2707671824 -17776 0 BMT}
| | | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Bogota) {
{-9223372036854775808 -17776 0 LMT}
{-2707671824 -17776 0 BMT}
{-1739041424 -18000 0 -0500}
{704869200 -14400 1 -0400}
{729057600 -18000 0 -0500}
}
|
Changes to library/tzdata/America/Campo_Grande.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Campo_Grande) {
{-9223372036854775808 -13108 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Campo_Grande) {
{-9223372036854775808 -13108 0 LMT}
{-1767212492 -14400 0 -0400}
{-1206954000 -10800 1 -0300}
{-1191358800 -14400 0 -0400}
{-1175371200 -10800 1 -0300}
{-1159822800 -14400 0 -0400}
{-633816000 -10800 1 -0300}
{-622065600 -14400 0 -0400}
{-602280000 -10800 1 -0300}
{-591829200 -14400 0 -0400}
{-570744000 -10800 1 -0300}
{-560206800 -14400 0 -0400}
{-539121600 -10800 1 -0300}
{-531349200 -14400 0 -0400}
{-191361600 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-155160000 -10800 1 -0300}
{-150066000 -14400 0 -0400}
{-128894400 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-99950400 -10800 1 -0300}
{-89586000 -14400 0 -0400}
{-68414400 -10800 1 -0300}
{-57963600 -14400 0 -0400}
{499752000 -10800 1 -0300}
{511239600 -14400 0 -0400}
{530596800 -10800 1 -0300}
{540270000 -14400 0 -0400}
{562132800 -10800 1 -0300}
{571201200 -14400 0 -0400}
{592977600 -10800 1 -0300}
{602046000 -14400 0 -0400}
{624427200 -10800 1 -0300}
{634705200 -14400 0 -0400}
{656481600 -10800 1 -0300}
{666759600 -14400 0 -0400}
{687931200 -10800 1 -0300}
{697604400 -14400 0 -0400}
{719985600 -10800 1 -0300}
{728449200 -14400 0 -0400}
{750830400 -10800 1 -0300}
{761713200 -14400 0 -0400}
{782280000 -10800 1 -0300}
{793162800 -14400 0 -0400}
{813729600 -10800 1 -0300}
{824007600 -14400 0 -0400}
{844574400 -10800 1 -0300}
{856062000 -14400 0 -0400}
{876110400 -10800 1 -0300}
{888721200 -14400 0 -0400}
{908078400 -10800 1 -0300}
{919566000 -14400 0 -0400}
{938923200 -10800 1 -0300}
{951620400 -14400 0 -0400}
{970977600 -10800 1 -0300}
{982465200 -14400 0 -0400}
{1003032000 -10800 1 -0300}
{1013914800 -14400 0 -0400}
{1036296000 -10800 1 -0300}
{1045364400 -14400 0 -0400}
{1066536000 -10800 1 -0300}
{1076814000 -14400 0 -0400}
{1099368000 -10800 1 -0300}
{1108868400 -14400 0 -0400}
{1129435200 -10800 1 -0300}
{1140318000 -14400 0 -0400}
{1162699200 -10800 1 -0300}
{1172372400 -14400 0 -0400}
{1192334400 -10800 1 -0300}
{1203217200 -14400 0 -0400}
{1224388800 -10800 1 -0300}
{1234666800 -14400 0 -0400}
{1255838400 -10800 1 -0300}
{1266721200 -14400 0 -0400}
{1287288000 -10800 1 -0300}
{1298170800 -14400 0 -0400}
{1318737600 -10800 1 -0300}
{1330225200 -14400 0 -0400}
{1350792000 -10800 1 -0300}
{1361070000 -14400 0 -0400}
{1382241600 -10800 1 -0300}
{1392519600 -14400 0 -0400}
{1413691200 -10800 1 -0300}
{1424574000 -14400 0 -0400}
{1445140800 -10800 1 -0300}
{1456023600 -14400 0 -0400}
{1476590400 -10800 1 -0300}
{1487473200 -14400 0 -0400}
{1508040000 -10800 1 -0300}
{1518922800 -14400 0 -0400}
{1541304000 -10800 1 -0300}
{1550372400 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Cancun.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cancun) {
{-9223372036854775808 -20824 0 LMT}
{-1514743200 -21600 0 CST}
| | | | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cancun) {
{-9223372036854775808 -20824 0 LMT}
{-1514743200 -21600 0 CST}
{378201600 -18000 0 EST}
{410504400 -21600 0 CST}
{828864000 -18000 1 CDT}
{846399600 -21600 0 CST}
{860313600 -18000 1 CDT}
{877852800 -18000 0 EST}
{891759600 -14400 1 EDT}
{902041200 -18000 0 CDT}
{909298800 -21600 0 CST}
{923212800 -18000 1 CDT}
{941353200 -21600 0 CST}
{954662400 -18000 1 CDT}
{972802800 -21600 0 CST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Caracas.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Caracas) {
{-9223372036854775808 -16064 0 LMT}
{-2524505536 -16060 0 CMT}
| | | | | | 1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Caracas) {
{-9223372036854775808 -16064 0 LMT}
{-2524505536 -16060 0 CMT}
{-1826739140 -16200 0 -0530}
{-157750200 -14400 0 -0400}
{1197183600 -16200 0 -0530}
{1462086000 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Cayenne.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cayenne) {
{-9223372036854775808 -12560 0 LMT}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cayenne) {
{-9223372036854775808 -12560 0 LMT}
{-1846269040 -14400 0 -0400}
{-71092800 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Chihuahua.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Chihuahua) {
{-9223372036854775808 -25460 0 LMT}
{-1514739600 -25200 0 MST}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Chihuahua) {
{-9223372036854775808 -25460 0 LMT}
{-1514739600 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{820476000 -21600 0 CST}
{828864000 -18000 1 CDT}
{846399600 -21600 0 CST}
{860313600 -18000 1 CDT}
{877849200 -21600 0 CST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Ciudad_Juarez.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Ciudad_Juarez) {
{-9223372036854775808 -25556 0 LMT}
{-1514739600 -25200 0 MST}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Ciudad_Juarez) {
{-9223372036854775808 -25556 0 LMT}
{-1514739600 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{820476000 -21600 0 CST}
{828864000 -18000 1 CDT}
{846399600 -21600 0 CST}
{860313600 -18000 1 CDT}
{877849200 -21600 0 CST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Cuiaba.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cuiaba) {
{-9223372036854775808 -13460 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Cuiaba) {
{-9223372036854775808 -13460 0 LMT}
{-1767212140 -14400 0 -0400}
{-1206954000 -10800 1 -0300}
{-1191358800 -14400 0 -0400}
{-1175371200 -10800 1 -0300}
{-1159822800 -14400 0 -0400}
{-633816000 -10800 1 -0300}
{-622065600 -14400 0 -0400}
{-602280000 -10800 1 -0300}
{-591829200 -14400 0 -0400}
{-570744000 -10800 1 -0300}
{-560206800 -14400 0 -0400}
{-539121600 -10800 1 -0300}
{-531349200 -14400 0 -0400}
{-191361600 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-155160000 -10800 1 -0300}
{-150066000 -14400 0 -0400}
{-128894400 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-99950400 -10800 1 -0300}
{-89586000 -14400 0 -0400}
{-68414400 -10800 1 -0300}
{-57963600 -14400 0 -0400}
{499752000 -10800 1 -0300}
{511239600 -14400 0 -0400}
{530596800 -10800 1 -0300}
{540270000 -14400 0 -0400}
{562132800 -10800 1 -0300}
{571201200 -14400 0 -0400}
{592977600 -10800 1 -0300}
{602046000 -14400 0 -0400}
{624427200 -10800 1 -0300}
{634705200 -14400 0 -0400}
{656481600 -10800 1 -0300}
{666759600 -14400 0 -0400}
{687931200 -10800 1 -0300}
{697604400 -14400 0 -0400}
{719985600 -10800 1 -0300}
{728449200 -14400 0 -0400}
{750830400 -10800 1 -0300}
{761713200 -14400 0 -0400}
{782280000 -10800 1 -0300}
{793162800 -14400 0 -0400}
{813729600 -10800 1 -0300}
{824007600 -14400 0 -0400}
{844574400 -10800 1 -0300}
{856062000 -14400 0 -0400}
{876110400 -10800 1 -0300}
{888721200 -14400 0 -0400}
{908078400 -10800 1 -0300}
{919566000 -14400 0 -0400}
{938923200 -10800 1 -0300}
{951620400 -14400 0 -0400}
{970977600 -10800 1 -0300}
{982465200 -14400 0 -0400}
{1003032000 -10800 1 -0300}
{1013914800 -14400 0 -0400}
{1036296000 -10800 1 -0300}
{1045364400 -14400 0 -0400}
{1064372400 -14400 0 -0400}
{1096603200 -14400 0 -0400}
{1099368000 -10800 1 -0300}
{1108868400 -14400 0 -0400}
{1129435200 -10800 1 -0300}
{1140318000 -14400 0 -0400}
{1162699200 -10800 1 -0300}
{1172372400 -14400 0 -0400}
{1192334400 -10800 1 -0300}
{1203217200 -14400 0 -0400}
{1224388800 -10800 1 -0300}
{1234666800 -14400 0 -0400}
{1255838400 -10800 1 -0300}
{1266721200 -14400 0 -0400}
{1287288000 -10800 1 -0300}
{1298170800 -14400 0 -0400}
{1318737600 -10800 1 -0300}
{1330225200 -14400 0 -0400}
{1350792000 -10800 1 -0300}
{1361070000 -14400 0 -0400}
{1382241600 -10800 1 -0300}
{1392519600 -14400 0 -0400}
{1413691200 -10800 1 -0300}
{1424574000 -14400 0 -0400}
{1445140800 -10800 1 -0300}
{1456023600 -14400 0 -0400}
{1476590400 -10800 1 -0300}
{1487473200 -14400 0 -0400}
{1508040000 -10800 1 -0300}
{1518922800 -14400 0 -0400}
{1541304000 -10800 1 -0300}
{1550372400 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Danmarkshavn.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Danmarkshavn) {
{-9223372036854775808 -4480 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Danmarkshavn) {
{-9223372036854775808 -4480 0 LMT}
{-1686091520 -10800 0 -0300}
{323845200 -7200 0 -0200}
{338950800 -10800 0 -0300}
{354675600 -7200 1 -0200}
{370400400 -10800 0 -0300}
{386125200 -7200 1 -0200}
{401850000 -10800 0 -0300}
{417574800 -7200 1 -0200}
{433299600 -10800 0 -0300}
{449024400 -7200 1 -0200}
{465354000 -10800 0 -0300}
{481078800 -7200 1 -0200}
{496803600 -10800 0 -0300}
{512528400 -7200 1 -0200}
{528253200 -10800 0 -0300}
{543978000 -7200 1 -0200}
{559702800 -10800 0 -0300}
{575427600 -7200 1 -0200}
{591152400 -10800 0 -0300}
{606877200 -7200 1 -0200}
{622602000 -10800 0 -0300}
{638326800 -7200 1 -0200}
{654656400 -10800 0 -0300}
{670381200 -7200 1 -0200}
{686106000 -10800 0 -0300}
{701830800 -7200 1 -0200}
{717555600 -10800 0 -0300}
{733280400 -7200 1 -0200}
{749005200 -10800 0 -0300}
{764730000 -7200 1 -0200}
{780454800 -10800 0 -0300}
{796179600 -7200 1 -0200}
{811904400 -10800 0 -0300}
{820465200 0 0 GMT}
}
|
Changes to library/tzdata/America/Eirunepe.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Eirunepe) {
{-9223372036854775808 -16768 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Eirunepe) {
{-9223372036854775808 -16768 0 LMT}
{-1767208832 -18000 0 -0500}
{-1206950400 -14400 1 -0400}
{-1191355200 -18000 0 -0500}
{-1175367600 -14400 1 -0400}
{-1159819200 -18000 0 -0500}
{-633812400 -14400 1 -0400}
{-622062000 -18000 0 -0500}
{-602276400 -14400 1 -0400}
{-591825600 -18000 0 -0500}
{-570740400 -14400 1 -0400}
{-560203200 -18000 0 -0500}
{-539118000 -14400 1 -0400}
{-531345600 -18000 0 -0500}
{-191358000 -14400 1 -0400}
{-184190400 -18000 0 -0500}
{-155156400 -14400 1 -0400}
{-150062400 -18000 0 -0500}
{-128890800 -14400 1 -0400}
{-121118400 -18000 0 -0500}
{-99946800 -14400 1 -0400}
{-89582400 -18000 0 -0500}
{-68410800 -14400 1 -0400}
{-57960000 -18000 0 -0500}
{499755600 -14400 1 -0400}
{511243200 -18000 0 -0500}
{530600400 -14400 1 -0400}
{540273600 -18000 0 -0500}
{562136400 -14400 1 -0400}
{571204800 -18000 0 -0500}
{590040000 -18000 0 -0500}
{749192400 -18000 0 -0500}
{750834000 -14400 1 -0400}
{761716800 -18000 0 -0500}
{780206400 -18000 0 -0500}
{1214283600 -14400 0 -0400}
{1384056000 -18000 0 -0500}
}
|
Changes to library/tzdata/America/Fortaleza.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Fortaleza) {
{-9223372036854775808 -9240 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Fortaleza) {
{-9223372036854775808 -9240 0 LMT}
{-1767216360 -10800 0 -0300}
{-1206957600 -7200 1 -0200}
{-1191362400 -10800 0 -0300}
{-1175374800 -7200 1 -0200}
{-1159826400 -10800 0 -0300}
{-633819600 -7200 1 -0200}
{-622069200 -10800 0 -0300}
{-602283600 -7200 1 -0200}
{-591832800 -10800 0 -0300}
{-570747600 -7200 1 -0200}
{-560210400 -10800 0 -0300}
{-539125200 -7200 1 -0200}
{-531352800 -10800 0 -0300}
{-191365200 -7200 1 -0200}
{-184197600 -10800 0 -0300}
{-155163600 -7200 1 -0200}
{-150069600 -10800 0 -0300}
{-128898000 -7200 1 -0200}
{-121125600 -10800 0 -0300}
{-99954000 -7200 1 -0200}
{-89589600 -10800 0 -0300}
{-68418000 -7200 1 -0200}
{-57967200 -10800 0 -0300}
{499748400 -7200 1 -0200}
{511236000 -10800 0 -0300}
{530593200 -7200 1 -0200}
{540266400 -10800 0 -0300}
{562129200 -7200 1 -0200}
{571197600 -10800 0 -0300}
{592974000 -7200 1 -0200}
{602042400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{634701600 -10800 0 -0300}
{653536800 -10800 0 -0300}
{938660400 -10800 0 -0300}
{938919600 -7200 1 -0200}
{951616800 -10800 0 -0300}
{970974000 -7200 1 -0200}
{972180000 -10800 0 -0300}
{1000350000 -10800 0 -0300}
{1003028400 -7200 1 -0200}
{1013911200 -10800 0 -0300}
{1033437600 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Guayaquil.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Guayaquil) {
{-9223372036854775808 -19160 0 LMT}
{-2524502440 -18840 0 QMT}
| | | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Guayaquil) {
{-9223372036854775808 -19160 0 LMT}
{-2524502440 -18840 0 QMT}
{-1230749160 -18000 0 -0500}
{722926800 -14400 1 -0400}
{728884800 -18000 0 -0500}
}
|
Changes to library/tzdata/America/Guyana.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Guyana) {
{-9223372036854775808 -13959 0 LMT}
| | | | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Guyana) {
{-9223372036854775808 -13959 0 LMT}
{-1843589241 -14400 0 -0400}
{-1730577600 -13500 0 -0445}
{176096700 -10800 0 -0300}
{701841600 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Hermosillo.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Hermosillo) {
{-9223372036854775808 -26632 0 LMT}
{-1514739600 -25200 0 MST}
| | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Hermosillo) {
{-9223372036854775808 -26632 0 LMT}
{-1514739600 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-873828000 -25200 0 MST}
{820479600 -25200 0 MST}
{828867600 -21600 1 MDT}
{846403200 -25200 0 MST}
{860317200 -21600 1 MDT}
{877852800 -25200 0 MST}
{891766800 -21600 1 MDT}
{909302400 -25200 0 MST}
{915174000 -25200 0 MST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/La_Paz.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/La_Paz) {
{-9223372036854775808 -16356 0 LMT}
{-2524505244 -16356 0 CMT}
{-1205954844 -12756 1 BST}
| | | 1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/La_Paz) {
{-9223372036854775808 -16356 0 LMT}
{-2524505244 -16356 0 CMT}
{-1205954844 -12756 1 BST}
{-1192307244 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Lima.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Lima) {
{-9223372036854775808 -18492 0 LMT}
{-2524503108 -18516 0 LMT}
| | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Lima) {
{-9223372036854775808 -18492 0 LMT}
{-2524503108 -18516 0 LMT}
{-1938538284 -14400 0 -0400}
{-1002052800 -18000 0 -0500}
{-986756400 -14400 1 -0400}
{-971035200 -18000 0 -0500}
{-955306800 -14400 1 -0400}
{-939585600 -18000 0 -0500}
{512712000 -18000 0 -0500}
{544248000 -18000 0 -0500}
{638942400 -18000 0 -0500}
{765172800 -18000 0 -0500}
}
|
Changes to library/tzdata/America/Maceio.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Maceio) {
{-9223372036854775808 -8572 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Maceio) {
{-9223372036854775808 -8572 0 LMT}
{-1767217028 -10800 0 -0300}
{-1206957600 -7200 1 -0200}
{-1191362400 -10800 0 -0300}
{-1175374800 -7200 1 -0200}
{-1159826400 -10800 0 -0300}
{-633819600 -7200 1 -0200}
{-622069200 -10800 0 -0300}
{-602283600 -7200 1 -0200}
{-591832800 -10800 0 -0300}
{-570747600 -7200 1 -0200}
{-560210400 -10800 0 -0300}
{-539125200 -7200 1 -0200}
{-531352800 -10800 0 -0300}
{-191365200 -7200 1 -0200}
{-184197600 -10800 0 -0300}
{-155163600 -7200 1 -0200}
{-150069600 -10800 0 -0300}
{-128898000 -7200 1 -0200}
{-121125600 -10800 0 -0300}
{-99954000 -7200 1 -0200}
{-89589600 -10800 0 -0300}
{-68418000 -7200 1 -0200}
{-57967200 -10800 0 -0300}
{499748400 -7200 1 -0200}
{511236000 -10800 0 -0300}
{530593200 -7200 1 -0200}
{540266400 -10800 0 -0300}
{562129200 -7200 1 -0200}
{571197600 -10800 0 -0300}
{592974000 -7200 1 -0200}
{602042400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{634701600 -10800 0 -0300}
{653536800 -10800 0 -0300}
{813553200 -10800 0 -0300}
{813726000 -7200 1 -0200}
{824004000 -10800 0 -0300}
{841802400 -10800 0 -0300}
{938660400 -10800 0 -0300}
{938919600 -7200 1 -0200}
{951616800 -10800 0 -0300}
{970974000 -7200 1 -0200}
{972180000 -10800 0 -0300}
{1000350000 -10800 0 -0300}
{1003028400 -7200 1 -0200}
{1013911200 -10800 0 -0300}
{1033437600 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Manaus.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Manaus) {
{-9223372036854775808 -14404 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Manaus) {
{-9223372036854775808 -14404 0 LMT}
{-1767211196 -14400 0 -0400}
{-1206954000 -10800 1 -0300}
{-1191358800 -14400 0 -0400}
{-1175371200 -10800 1 -0300}
{-1159822800 -14400 0 -0400}
{-633816000 -10800 1 -0300}
{-622065600 -14400 0 -0400}
{-602280000 -10800 1 -0300}
{-591829200 -14400 0 -0400}
{-570744000 -10800 1 -0300}
{-560206800 -14400 0 -0400}
{-539121600 -10800 1 -0300}
{-531349200 -14400 0 -0400}
{-191361600 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-155160000 -10800 1 -0300}
{-150066000 -14400 0 -0400}
{-128894400 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-99950400 -10800 1 -0300}
{-89586000 -14400 0 -0400}
{-68414400 -10800 1 -0300}
{-57963600 -14400 0 -0400}
{499752000 -10800 1 -0300}
{511239600 -14400 0 -0400}
{530596800 -10800 1 -0300}
{540270000 -14400 0 -0400}
{562132800 -10800 1 -0300}
{571201200 -14400 0 -0400}
{590036400 -14400 0 -0400}
{749188800 -14400 0 -0400}
{750830400 -10800 1 -0300}
{761713200 -14400 0 -0400}
{780202800 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Mazatlan.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Mazatlan) {
{-9223372036854775808 -25540 0 LMT}
{-1514739600 -25200 0 MST}
| | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Mazatlan) {
{-9223372036854775808 -25540 0 LMT}
{-1514739600 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-873828000 -25200 0 MST}
{25200 -25200 0 MST}
{828867600 -21600 1 MDT}
{846403200 -25200 0 MST}
{860317200 -21600 1 MDT}
{877852800 -25200 0 MST}
{891766800 -21600 1 MDT}
{909302400 -25200 0 MST}
{923216400 -21600 1 MDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Merida.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Merida) {
{-9223372036854775808 -21508 0 LMT}
{-1514743200 -21600 0 CST}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Merida) {
{-9223372036854775808 -21508 0 LMT}
{-1514743200 -21600 0 CST}
{378201600 -18000 0 EST}
{405068400 -21600 0 CST}
{828864000 -18000 1 CDT}
{846399600 -21600 0 CST}
{860313600 -18000 1 CDT}
{877849200 -21600 0 CST}
{891763200 -18000 1 CDT}
{909298800 -21600 0 CST}
{923212800 -18000 1 CDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Mexico_City.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Mexico_City) {
{-9223372036854775808 -23796 0 LMT}
{-1514739600 -25200 0 MST}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Mexico_City) {
{-9223372036854775808 -23796 0 LMT}
{-1514739600 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-975261600 -18000 1 CDT}
{-963169200 -21600 0 CST}
{-917114400 -18000 1 CDT}
{-907354800 -21600 0 CST}
{-821901600 -18000 1 CWT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Miquelon.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Miquelon) {
{-9223372036854775808 -13480 0 LMT}
{-1847650520 -14400 0 AST}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Miquelon) {
{-9223372036854775808 -13480 0 LMT}
{-1847650520 -14400 0 AST}
{326001600 -10800 0 -0300}
{536468400 -10800 0 -0300}
{544597200 -7200 1 -0200}
{562132800 -10800 0 -0300}
{576046800 -7200 1 -0200}
{594187200 -10800 0 -0300}
{607496400 -7200 1 -0200}
{625636800 -10800 0 -0300}
{638946000 -7200 1 -0200}
{657086400 -10800 0 -0300}
{671000400 -7200 1 -0200}
{688536000 -10800 0 -0300}
{702450000 -7200 1 -0200}
{719985600 -10800 0 -0300}
{733899600 -7200 1 -0200}
{752040000 -10800 0 -0300}
{765349200 -7200 1 -0200}
{783489600 -10800 0 -0300}
{796798800 -7200 1 -0200}
{814939200 -10800 0 -0300}
{828853200 -7200 1 -0200}
{846388800 -10800 0 -0300}
{860302800 -7200 1 -0200}
{877838400 -10800 0 -0300}
{891752400 -7200 1 -0200}
{909288000 -10800 0 -0300}
{923202000 -7200 1 -0200}
{941342400 -10800 0 -0300}
{954651600 -7200 1 -0200}
{972792000 -10800 0 -0300}
{986101200 -7200 1 -0200}
{1004241600 -10800 0 -0300}
{1018155600 -7200 1 -0200}
{1035691200 -10800 0 -0300}
{1049605200 -7200 1 -0200}
{1067140800 -10800 0 -0300}
{1081054800 -7200 1 -0200}
{1099195200 -10800 0 -0300}
{1112504400 -7200 1 -0200}
{1130644800 -10800 0 -0300}
{1143954000 -7200 1 -0200}
{1162094400 -10800 0 -0300}
{1173589200 -7200 1 -0200}
{1194148800 -10800 0 -0300}
{1205038800 -7200 1 -0200}
{1225598400 -10800 0 -0300}
{1236488400 -7200 1 -0200}
{1257048000 -10800 0 -0300}
{1268542800 -7200 1 -0200}
{1289102400 -10800 0 -0300}
{1299992400 -7200 1 -0200}
{1320552000 -10800 0 -0300}
{1331442000 -7200 1 -0200}
{1352001600 -10800 0 -0300}
{1362891600 -7200 1 -0200}
{1383451200 -10800 0 -0300}
{1394341200 -7200 1 -0200}
{1414900800 -10800 0 -0300}
{1425790800 -7200 1 -0200}
{1446350400 -10800 0 -0300}
{1457845200 -7200 1 -0200}
{1478404800 -10800 0 -0300}
{1489294800 -7200 1 -0200}
{1509854400 -10800 0 -0300}
{1520744400 -7200 1 -0200}
{1541304000 -10800 0 -0300}
{1552194000 -7200 1 -0200}
{1572753600 -10800 0 -0300}
{1583643600 -7200 1 -0200}
{1604203200 -10800 0 -0300}
{1615698000 -7200 1 -0200}
{1636257600 -10800 0 -0300}
{1647147600 -7200 1 -0200}
{1667707200 -10800 0 -0300}
{1678597200 -7200 1 -0200}
{1699156800 -10800 0 -0300}
{1710046800 -7200 1 -0200}
{1730606400 -10800 0 -0300}
{1741496400 -7200 1 -0200}
{1762056000 -10800 0 -0300}
{1772946000 -7200 1 -0200}
{1793505600 -10800 0 -0300}
{1805000400 -7200 1 -0200}
{1825560000 -10800 0 -0300}
{1836450000 -7200 1 -0200}
{1857009600 -10800 0 -0300}
{1867899600 -7200 1 -0200}
{1888459200 -10800 0 -0300}
{1899349200 -7200 1 -0200}
{1919908800 -10800 0 -0300}
{1930798800 -7200 1 -0200}
{1951358400 -10800 0 -0300}
{1962853200 -7200 1 -0200}
{1983412800 -10800 0 -0300}
{1994302800 -7200 1 -0200}
{2014862400 -10800 0 -0300}
{2025752400 -7200 1 -0200}
{2046312000 -10800 0 -0300}
{2057202000 -7200 1 -0200}
{2077761600 -10800 0 -0300}
{2088651600 -7200 1 -0200}
{2109211200 -10800 0 -0300}
{2120101200 -7200 1 -0200}
{2140660800 -10800 0 -0300}
{2152155600 -7200 1 -0200}
{2172715200 -10800 0 -0300}
{2183605200 -7200 1 -0200}
{2204164800 -10800 0 -0300}
{2215054800 -7200 1 -0200}
{2235614400 -10800 0 -0300}
{2246504400 -7200 1 -0200}
{2267064000 -10800 0 -0300}
{2277954000 -7200 1 -0200}
{2298513600 -10800 0 -0300}
{2309403600 -7200 1 -0200}
{2329963200 -10800 0 -0300}
{2341458000 -7200 1 -0200}
{2362017600 -10800 0 -0300}
{2372907600 -7200 1 -0200}
{2393467200 -10800 0 -0300}
{2404357200 -7200 1 -0200}
{2424916800 -10800 0 -0300}
{2435806800 -7200 1 -0200}
{2456366400 -10800 0 -0300}
{2467256400 -7200 1 -0200}
{2487816000 -10800 0 -0300}
{2499310800 -7200 1 -0200}
{2519870400 -10800 0 -0300}
{2530760400 -7200 1 -0200}
{2551320000 -10800 0 -0300}
{2562210000 -7200 1 -0200}
{2582769600 -10800 0 -0300}
{2593659600 -7200 1 -0200}
{2614219200 -10800 0 -0300}
{2625109200 -7200 1 -0200}
{2645668800 -10800 0 -0300}
{2656558800 -7200 1 -0200}
{2677118400 -10800 0 -0300}
{2688613200 -7200 1 -0200}
{2709172800 -10800 0 -0300}
{2720062800 -7200 1 -0200}
{2740622400 -10800 0 -0300}
{2751512400 -7200 1 -0200}
{2772072000 -10800 0 -0300}
{2782962000 -7200 1 -0200}
{2803521600 -10800 0 -0300}
{2814411600 -7200 1 -0200}
{2834971200 -10800 0 -0300}
{2846466000 -7200 1 -0200}
{2867025600 -10800 0 -0300}
{2877915600 -7200 1 -0200}
{2898475200 -10800 0 -0300}
{2909365200 -7200 1 -0200}
{2929924800 -10800 0 -0300}
{2940814800 -7200 1 -0200}
{2961374400 -10800 0 -0300}
{2972264400 -7200 1 -0200}
{2992824000 -10800 0 -0300}
{3003714000 -7200 1 -0200}
{3024273600 -10800 0 -0300}
{3035768400 -7200 1 -0200}
{3056328000 -10800 0 -0300}
{3067218000 -7200 1 -0200}
{3087777600 -10800 0 -0300}
{3098667600 -7200 1 -0200}
{3119227200 -10800 0 -0300}
{3130117200 -7200 1 -0200}
{3150676800 -10800 0 -0300}
{3161566800 -7200 1 -0200}
{3182126400 -10800 0 -0300}
{3193016400 -7200 1 -0200}
{3213576000 -10800 0 -0300}
{3225070800 -7200 1 -0200}
{3245630400 -10800 0 -0300}
{3256520400 -7200 1 -0200}
{3277080000 -10800 0 -0300}
{3287970000 -7200 1 -0200}
{3308529600 -10800 0 -0300}
{3319419600 -7200 1 -0200}
{3339979200 -10800 0 -0300}
{3350869200 -7200 1 -0200}
{3371428800 -10800 0 -0300}
{3382923600 -7200 1 -0200}
{3403483200 -10800 0 -0300}
{3414373200 -7200 1 -0200}
{3434932800 -10800 0 -0300}
{3445822800 -7200 1 -0200}
{3466382400 -10800 0 -0300}
{3477272400 -7200 1 -0200}
{3497832000 -10800 0 -0300}
{3508722000 -7200 1 -0200}
{3529281600 -10800 0 -0300}
{3540171600 -7200 1 -0200}
{3560731200 -10800 0 -0300}
{3572226000 -7200 1 -0200}
{3592785600 -10800 0 -0300}
{3603675600 -7200 1 -0200}
{3624235200 -10800 0 -0300}
{3635125200 -7200 1 -0200}
{3655684800 -10800 0 -0300}
{3666574800 -7200 1 -0200}
{3687134400 -10800 0 -0300}
{3698024400 -7200 1 -0200}
{3718584000 -10800 0 -0300}
{3730078800 -7200 1 -0200}
{3750638400 -10800 0 -0300}
{3761528400 -7200 1 -0200}
{3782088000 -10800 0 -0300}
{3792978000 -7200 1 -0200}
{3813537600 -10800 0 -0300}
{3824427600 -7200 1 -0200}
{3844987200 -10800 0 -0300}
{3855877200 -7200 1 -0200}
{3876436800 -10800 0 -0300}
{3887326800 -7200 1 -0200}
{3907886400 -10800 0 -0300}
{3919381200 -7200 1 -0200}
{3939940800 -10800 0 -0300}
{3950830800 -7200 1 -0200}
{3971390400 -10800 0 -0300}
{3982280400 -7200 1 -0200}
{4002840000 -10800 0 -0300}
{4013730000 -7200 1 -0200}
{4034289600 -10800 0 -0300}
{4045179600 -7200 1 -0200}
{4065739200 -10800 0 -0300}
{4076629200 -7200 1 -0200}
{4097188800 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Monterrey.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Monterrey) {
{-9223372036854775808 -24076 0 LMT}
| | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Monterrey) {
{-9223372036854775808 -24076 0 LMT}
{-1514743200 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{568015200 -21600 0 CST}
{576057600 -18000 1 CDT}
{594198000 -21600 0 CST}
{599637600 -21600 0 CST}
{828864000 -18000 1 CDT}
{846399600 -21600 0 CST}
{860313600 -18000 1 CDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Montevideo.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Montevideo) {
{-9223372036854775808 -13491 0 LMT}
{-1942690509 -13491 0 MMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Montevideo) {
{-9223372036854775808 -13491 0 LMT}
{-1942690509 -13491 0 MMT}
{-1567455309 -14400 0 -0400}
{-1459627200 -10800 0 -0300}
{-1443819600 -12600 0 -0430}
{-1428006600 -10800 1 -0300}
{-1412283600 -12600 0 -0430}
{-1396470600 -10800 1 -0300}
{-1380747600 -12600 0 -0430}
{-1141590600 -10800 1 -0300}
{-1128286800 -12600 0 -0430}
{-1110141000 -10800 1 -0300}
{-1096837200 -12600 0 -0430}
{-1078691400 -10800 1 -0300}
{-1065387600 -12600 0 -0430}
{-1047241800 -10800 1 -0300}
{-1033938000 -12600 0 -0430}
{-1015187400 -10800 1 -0300}
{-1002488400 -12600 0 -0430}
{-983737800 -10800 1 -0300}
{-971038800 -12600 0 -0430}
{-954707400 -10800 1 -0300}
{-938984400 -12600 0 -0430}
{-920838600 -10800 1 -0300}
{-907534800 -12600 0 -0430}
{-896819400 -10800 1 -0300}
{-853621200 -9000 0 -0330}
{-845847000 -10800 0 -0300}
{-334789200 -9000 1 -0330}
{-319671000 -10800 0 -0300}
{-315608400 -10800 0 -0300}
{-314226000 -7200 1 -0200}
{-309996000 -10800 0 -0300}
{-149720400 -7200 1 -0200}
{-134604000 -10800 0 -0300}
{-63147600 -10800 0 -0300}
{-50446800 -9000 1 -0330}
{-34205400 -10800 0 -0300}
{10800 -10800 0 -0300}
{9860400 -7200 1 -0200}
{14176800 -10800 0 -0300}
{72846000 -7200 1 -0200}
{80100000 -10800 0 -0300}
{126241200 -10800 0 -0300}
{127278000 -5400 1 -0230}
{132112800 -9000 0 -0330}
{147234600 -10800 0 -0300}
{156909600 -10800 0 -0300}
{156913200 -7200 1 -0200}
{165376800 -10800 0 -0300}
{219812400 -7200 1 -0200}
{226461600 -10800 0 -0300}
{250052400 -7200 1 -0200}
{257911200 -10800 0 -0300}
{282711600 -7200 1 -0200}
{289360800 -10800 0 -0300}
{294202800 -7200 1 -0200}
{322020000 -10800 0 -0300}
{566449200 -7200 1 -0200}
{573012000 -10800 0 -0300}
{597812400 -7200 1 -0200}
{605066400 -10800 0 -0300}
{625633200 -7200 1 -0200}
{635911200 -10800 0 -0300}
{656478000 -7200 1 -0200}
{667965600 -10800 0 -0300}
{688532400 -7200 1 -0200}
{699415200 -10800 0 -0300}
{719377200 -7200 1 -0200}
{730864800 -10800 0 -0300}
{1095562800 -7200 1 -0200}
{1111896000 -10800 0 -0300}
{1128834000 -7200 1 -0200}
{1142136000 -10800 0 -0300}
{1159678800 -7200 1 -0200}
{1173585600 -10800 0 -0300}
{1191733200 -7200 1 -0200}
{1205035200 -10800 0 -0300}
{1223182800 -7200 1 -0200}
{1236484800 -10800 0 -0300}
{1254632400 -7200 1 -0200}
{1268539200 -10800 0 -0300}
{1286082000 -7200 1 -0200}
{1299988800 -10800 0 -0300}
{1317531600 -7200 1 -0200}
{1331438400 -10800 0 -0300}
{1349586000 -7200 1 -0200}
{1362888000 -10800 0 -0300}
{1381035600 -7200 1 -0200}
{1394337600 -10800 0 -0300}
{1412485200 -7200 1 -0200}
{1425787200 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Noronha.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Noronha) {
{-9223372036854775808 -7780 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Noronha) {
{-9223372036854775808 -7780 0 LMT}
{-1767217820 -7200 0 -0200}
{-1206961200 -3600 1 -0100}
{-1191366000 -7200 0 -0200}
{-1175378400 -3600 1 -0100}
{-1159830000 -7200 0 -0200}
{-633823200 -3600 1 -0100}
{-622072800 -7200 0 -0200}
{-602287200 -3600 1 -0100}
{-591836400 -7200 0 -0200}
{-570751200 -3600 1 -0100}
{-560214000 -7200 0 -0200}
{-539128800 -3600 1 -0100}
{-531356400 -7200 0 -0200}
{-191368800 -3600 1 -0100}
{-184201200 -7200 0 -0200}
{-155167200 -3600 1 -0100}
{-150073200 -7200 0 -0200}
{-128901600 -3600 1 -0100}
{-121129200 -7200 0 -0200}
{-99957600 -3600 1 -0100}
{-89593200 -7200 0 -0200}
{-68421600 -3600 1 -0100}
{-57970800 -7200 0 -0200}
{499744800 -3600 1 -0100}
{511232400 -7200 0 -0200}
{530589600 -3600 1 -0100}
{540262800 -7200 0 -0200}
{562125600 -3600 1 -0100}
{571194000 -7200 0 -0200}
{592970400 -3600 1 -0100}
{602038800 -7200 0 -0200}
{624420000 -3600 1 -0100}
{634698000 -7200 0 -0200}
{653533200 -7200 0 -0200}
{938656800 -7200 0 -0200}
{938916000 -3600 1 -0100}
{951613200 -7200 0 -0200}
{970970400 -3600 1 -0100}
{971571600 -7200 0 -0200}
{1000346400 -7200 0 -0200}
{1003024800 -3600 1 -0100}
{1013907600 -7200 0 -0200}
{1033434000 -7200 0 -0200}
}
|
Changes to library/tzdata/America/Nuuk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Nuuk) {
{-9223372036854775808 -12416 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Nuuk) {
{-9223372036854775808 -12416 0 LMT}
{-1686083584 -10800 0 -0300}
{323845200 -7200 0 -0200}
{338950800 -10800 0 -0300}
{354675600 -7200 1 -0200}
{370400400 -10800 0 -0300}
{386125200 -7200 1 -0200}
{401850000 -10800 0 -0300}
{417574800 -7200 1 -0200}
{433299600 -10800 0 -0300}
{449024400 -7200 1 -0200}
{465354000 -10800 0 -0300}
{481078800 -7200 1 -0200}
{496803600 -10800 0 -0300}
{512528400 -7200 1 -0200}
{528253200 -10800 0 -0300}
{543978000 -7200 1 -0200}
{559702800 -10800 0 -0300}
{575427600 -7200 1 -0200}
{591152400 -10800 0 -0300}
{606877200 -7200 1 -0200}
{622602000 -10800 0 -0300}
{638326800 -7200 1 -0200}
{654656400 -10800 0 -0300}
{670381200 -7200 1 -0200}
{686106000 -10800 0 -0300}
{701830800 -7200 1 -0200}
{717555600 -10800 0 -0300}
{733280400 -7200 1 -0200}
{749005200 -10800 0 -0300}
{764730000 -7200 1 -0200}
{780454800 -10800 0 -0300}
{796179600 -7200 1 -0200}
{811904400 -10800 0 -0300}
{828234000 -7200 1 -0200}
{846378000 -10800 0 -0300}
{859683600 -7200 1 -0200}
{877827600 -10800 0 -0300}
{891133200 -7200 1 -0200}
{909277200 -10800 0 -0300}
{922582800 -7200 1 -0200}
{941331600 -10800 0 -0300}
{954032400 -7200 1 -0200}
{972781200 -10800 0 -0300}
{985482000 -7200 1 -0200}
{1004230800 -10800 0 -0300}
{1017536400 -7200 1 -0200}
{1035680400 -10800 0 -0300}
{1048986000 -7200 1 -0200}
{1067130000 -10800 0 -0300}
{1080435600 -7200 1 -0200}
{1099184400 -10800 0 -0300}
{1111885200 -7200 1 -0200}
{1130634000 -10800 0 -0300}
{1143334800 -7200 1 -0200}
{1162083600 -10800 0 -0300}
{1174784400 -7200 1 -0200}
{1193533200 -10800 0 -0300}
{1206838800 -7200 1 -0200}
{1224982800 -10800 0 -0300}
{1238288400 -7200 1 -0200}
{1256432400 -10800 0 -0300}
{1269738000 -7200 1 -0200}
{1288486800 -10800 0 -0300}
{1301187600 -7200 1 -0200}
{1319936400 -10800 0 -0300}
{1332637200 -7200 1 -0200}
{1351386000 -10800 0 -0300}
{1364691600 -7200 1 -0200}
{1382835600 -10800 0 -0300}
{1396141200 -7200 1 -0200}
{1414285200 -10800 0 -0300}
{1427590800 -7200 1 -0200}
{1445734800 -10800 0 -0300}
{1459040400 -7200 1 -0200}
{1477789200 -10800 0 -0300}
{1490490000 -7200 1 -0200}
{1509238800 -10800 0 -0300}
{1521939600 -7200 1 -0200}
{1540688400 -10800 0 -0300}
{1553994000 -7200 1 -0200}
{1572138000 -10800 0 -0300}
{1585443600 -7200 1 -0200}
{1603587600 -10800 0 -0300}
{1616893200 -7200 1 -0200}
{1635642000 -10800 0 -0300}
{1648342800 -7200 1 -0200}
{1667091600 -10800 0 -0300}
{1679792400 -7200 0 -0200}
{1698541200 -7200 0 -0200}
{1711846800 -3600 1 -0100}
{1729990800 -7200 0 -0200}
{1743296400 -3600 1 -0100}
{1761440400 -7200 0 -0200}
{1774746000 -3600 1 -0100}
{1792890000 -7200 0 -0200}
{1806195600 -3600 1 -0100}
{1824944400 -7200 0 -0200}
{1837645200 -3600 1 -0100}
{1856394000 -7200 0 -0200}
{1869094800 -3600 1 -0100}
{1887843600 -7200 0 -0200}
{1901149200 -3600 1 -0100}
{1919293200 -7200 0 -0200}
{1932598800 -3600 1 -0100}
{1950742800 -7200 0 -0200}
{1964048400 -3600 1 -0100}
{1982797200 -7200 0 -0200}
{1995498000 -3600 1 -0100}
{2014246800 -7200 0 -0200}
{2026947600 -3600 1 -0100}
{2045696400 -7200 0 -0200}
{2058397200 -3600 1 -0100}
{2077146000 -7200 0 -0200}
{2090451600 -3600 1 -0100}
{2108595600 -7200 0 -0200}
{2121901200 -3600 1 -0100}
{2140045200 -7200 0 -0200}
{2153350800 -3600 1 -0100}
{2172099600 -7200 0 -0200}
{2184800400 -3600 1 -0100}
{2203549200 -7200 0 -0200}
{2216250000 -3600 1 -0100}
{2234998800 -7200 0 -0200}
{2248304400 -3600 1 -0100}
{2266448400 -7200 0 -0200}
{2279754000 -3600 1 -0100}
{2297898000 -7200 0 -0200}
{2311203600 -3600 1 -0100}
{2329347600 -7200 0 -0200}
{2342653200 -3600 1 -0100}
{2361402000 -7200 0 -0200}
{2374102800 -3600 1 -0100}
{2392851600 -7200 0 -0200}
{2405552400 -3600 1 -0100}
{2424301200 -7200 0 -0200}
{2437606800 -3600 1 -0100}
{2455750800 -7200 0 -0200}
{2469056400 -3600 1 -0100}
{2487200400 -7200 0 -0200}
{2500506000 -3600 1 -0100}
{2519254800 -7200 0 -0200}
{2531955600 -3600 1 -0100}
{2550704400 -7200 0 -0200}
{2563405200 -3600 1 -0100}
{2582154000 -7200 0 -0200}
{2595459600 -3600 1 -0100}
{2613603600 -7200 0 -0200}
{2626909200 -3600 1 -0100}
{2645053200 -7200 0 -0200}
{2658358800 -3600 1 -0100}
{2676502800 -7200 0 -0200}
{2689808400 -3600 1 -0100}
{2708557200 -7200 0 -0200}
{2721258000 -3600 1 -0100}
{2740006800 -7200 0 -0200}
{2752707600 -3600 1 -0100}
{2771456400 -7200 0 -0200}
{2784762000 -3600 1 -0100}
{2802906000 -7200 0 -0200}
{2816211600 -3600 1 -0100}
{2834355600 -7200 0 -0200}
{2847661200 -3600 1 -0100}
{2866410000 -7200 0 -0200}
{2879110800 -3600 1 -0100}
{2897859600 -7200 0 -0200}
{2910560400 -3600 1 -0100}
{2929309200 -7200 0 -0200}
{2942010000 -3600 1 -0100}
{2960758800 -7200 0 -0200}
{2974064400 -3600 1 -0100}
{2992208400 -7200 0 -0200}
{3005514000 -3600 1 -0100}
{3023658000 -7200 0 -0200}
{3036963600 -3600 1 -0100}
{3055712400 -7200 0 -0200}
{3068413200 -3600 1 -0100}
{3087162000 -7200 0 -0200}
{3099862800 -3600 1 -0100}
{3118611600 -7200 0 -0200}
{3131917200 -3600 1 -0100}
{3150061200 -7200 0 -0200}
{3163366800 -3600 1 -0100}
{3181510800 -7200 0 -0200}
{3194816400 -3600 1 -0100}
{3212960400 -7200 0 -0200}
{3226266000 -3600 1 -0100}
{3245014800 -7200 0 -0200}
{3257715600 -3600 1 -0100}
{3276464400 -7200 0 -0200}
{3289165200 -3600 1 -0100}
{3307914000 -7200 0 -0200}
{3321219600 -3600 1 -0100}
{3339363600 -7200 0 -0200}
{3352669200 -3600 1 -0100}
{3370813200 -7200 0 -0200}
{3384118800 -3600 1 -0100}
{3402867600 -7200 0 -0200}
{3415568400 -3600 1 -0100}
{3434317200 -7200 0 -0200}
{3447018000 -3600 1 -0100}
{3465766800 -7200 0 -0200}
{3479072400 -3600 1 -0100}
{3497216400 -7200 0 -0200}
{3510522000 -3600 1 -0100}
{3528666000 -7200 0 -0200}
{3541971600 -3600 1 -0100}
{3560115600 -7200 0 -0200}
{3573421200 -3600 1 -0100}
{3592170000 -7200 0 -0200}
{3604870800 -3600 1 -0100}
{3623619600 -7200 0 -0200}
{3636320400 -3600 1 -0100}
{3655069200 -7200 0 -0200}
{3668374800 -3600 1 -0100}
{3686518800 -7200 0 -0200}
{3699824400 -3600 1 -0100}
{3717968400 -7200 0 -0200}
{3731274000 -3600 1 -0100}
{3750022800 -7200 0 -0200}
{3762723600 -3600 1 -0100}
{3781472400 -7200 0 -0200}
{3794173200 -3600 1 -0100}
{3812922000 -7200 0 -0200}
{3825622800 -3600 1 -0100}
{3844371600 -7200 0 -0200}
{3857677200 -3600 1 -0100}
{3875821200 -7200 0 -0200}
{3889126800 -3600 1 -0100}
{3907270800 -7200 0 -0200}
{3920576400 -3600 1 -0100}
{3939325200 -7200 0 -0200}
{3952026000 -3600 1 -0100}
{3970774800 -7200 0 -0200}
{3983475600 -3600 1 -0100}
{4002224400 -7200 0 -0200}
{4015530000 -3600 1 -0100}
{4033674000 -7200 0 -0200}
{4046979600 -3600 1 -0100}
{4065123600 -7200 0 -0200}
{4078429200 -3600 1 -0100}
{4096573200 -7200 0 -0200}
}
|
Changes to library/tzdata/America/Ojinaga.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Ojinaga) {
{-9223372036854775808 -25060 0 LMT}
{-1514739600 -25200 0 MST}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Ojinaga) {
{-9223372036854775808 -25060 0 LMT}
{-1514739600 -25200 0 MST}
{-1343149200 -21600 0 CST}
{-1234807200 -25200 0 MST}
{-1220461200 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{820476000 -21600 0 CST}
{828864000 -18000 1 CDT}
{846399600 -21600 0 CST}
{860313600 -18000 1 CDT}
{877849200 -21600 0 CST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Paramaribo.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Paramaribo) {
{-9223372036854775808 -13240 0 LMT}
{-1861906760 -13252 0 PMT}
{-1104524348 -13236 0 PMT}
| | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Paramaribo) {
{-9223372036854775808 -13240 0 LMT}
{-1861906760 -13252 0 PMT}
{-1104524348 -13236 0 PMT}
{-765317964 -12600 0 -0430}
{465449400 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Porto_Velho.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Porto_Velho) {
{-9223372036854775808 -15336 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Porto_Velho) {
{-9223372036854775808 -15336 0 LMT}
{-1767210264 -14400 0 -0400}
{-1206954000 -10800 1 -0300}
{-1191358800 -14400 0 -0400}
{-1175371200 -10800 1 -0300}
{-1159822800 -14400 0 -0400}
{-633816000 -10800 1 -0300}
{-622065600 -14400 0 -0400}
{-602280000 -10800 1 -0300}
{-591829200 -14400 0 -0400}
{-570744000 -10800 1 -0300}
{-560206800 -14400 0 -0400}
{-539121600 -10800 1 -0300}
{-531349200 -14400 0 -0400}
{-191361600 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-155160000 -10800 1 -0300}
{-150066000 -14400 0 -0400}
{-128894400 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-99950400 -10800 1 -0300}
{-89586000 -14400 0 -0400}
{-68414400 -10800 1 -0300}
{-57963600 -14400 0 -0400}
{499752000 -10800 1 -0300}
{511239600 -14400 0 -0400}
{530596800 -10800 1 -0300}
{540270000 -14400 0 -0400}
{562132800 -10800 1 -0300}
{571201200 -14400 0 -0400}
{590036400 -14400 0 -0400}
}
|
Changes to library/tzdata/America/Punta_Arenas.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Punta_Arenas) {
{-9223372036854775808 -17020 0 LMT}
{-2524504580 -16965 0 SMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Punta_Arenas) {
{-9223372036854775808 -17020 0 LMT}
{-2524504580 -16965 0 SMT}
{-1892661435 -18000 0 -0500}
{-1688410800 -16965 0 SMT}
{-1619205435 -14400 0 -0400}
{-1593806400 -16965 0 SMT}
{-1335986235 -18000 0 -0500}
{-1335985200 -14400 1 -0400}
{-1317585600 -18000 0 -0500}
{-1304362800 -14400 1 -0400}
{-1286049600 -18000 0 -0500}
{-1272826800 -14400 1 -0400}
{-1254513600 -18000 0 -0500}
{-1241290800 -14400 1 -0400}
{-1222977600 -18000 0 -0500}
{-1209754800 -14400 1 -0400}
{-1191355200 -18000 0 -0500}
{-1178132400 -14400 0 -0400}
{-870552000 -18000 0 -0500}
{-865278000 -14400 0 -0400}
{-736632000 -14400 1 -0400}
{-718056000 -18000 0 -0500}
{-713649600 -14400 0 -0400}
{-36619200 -10800 1 -0300}
{-23922000 -14400 0 -0400}
{-3355200 -10800 1 -0300}
{7527600 -14400 0 -0400}
{24465600 -10800 1 -0300}
{37767600 -14400 0 -0400}
{55915200 -10800 1 -0300}
{69217200 -14400 0 -0400}
{87969600 -10800 1 -0300}
{100666800 -14400 0 -0400}
{118209600 -10800 1 -0300}
{132116400 -14400 0 -0400}
{150868800 -10800 1 -0300}
{163566000 -14400 0 -0400}
{182318400 -10800 1 -0300}
{195620400 -14400 0 -0400}
{213768000 -10800 1 -0300}
{227070000 -14400 0 -0400}
{245217600 -10800 1 -0300}
{258519600 -14400 0 -0400}
{277272000 -10800 1 -0300}
{289969200 -14400 0 -0400}
{308721600 -10800 1 -0300}
{321418800 -14400 0 -0400}
{340171200 -10800 1 -0300}
{353473200 -14400 0 -0400}
{371620800 -10800 1 -0300}
{384922800 -14400 0 -0400}
{403070400 -10800 1 -0300}
{416372400 -14400 0 -0400}
{434520000 -10800 1 -0300}
{447822000 -14400 0 -0400}
{466574400 -10800 1 -0300}
{479271600 -14400 0 -0400}
{498024000 -10800 1 -0300}
{510721200 -14400 0 -0400}
{529473600 -10800 1 -0300}
{545194800 -14400 0 -0400}
{560923200 -10800 1 -0300}
{574225200 -14400 0 -0400}
{592372800 -10800 1 -0300}
{605674800 -14400 0 -0400}
{624427200 -10800 1 -0300}
{637124400 -14400 0 -0400}
{653457600 -10800 1 -0300}
{668574000 -14400 0 -0400}
{687326400 -10800 1 -0300}
{700628400 -14400 0 -0400}
{718776000 -10800 1 -0300}
{732078000 -14400 0 -0400}
{750225600 -10800 1 -0300}
{763527600 -14400 0 -0400}
{781675200 -10800 1 -0300}
{794977200 -14400 0 -0400}
{813729600 -10800 1 -0300}
{826426800 -14400 0 -0400}
{845179200 -10800 1 -0300}
{859690800 -14400 0 -0400}
{876628800 -10800 1 -0300}
{889930800 -14400 0 -0400}
{906868800 -10800 1 -0300}
{923194800 -14400 0 -0400}
{939528000 -10800 1 -0300}
{952830000 -14400 0 -0400}
{971582400 -10800 1 -0300}
{984279600 -14400 0 -0400}
{1003032000 -10800 1 -0300}
{1015729200 -14400 0 -0400}
{1034481600 -10800 1 -0300}
{1047178800 -14400 0 -0400}
{1065931200 -10800 1 -0300}
{1079233200 -14400 0 -0400}
{1097380800 -10800 1 -0300}
{1110682800 -14400 0 -0400}
{1128830400 -10800 1 -0300}
{1142132400 -14400 0 -0400}
{1160884800 -10800 1 -0300}
{1173582000 -14400 0 -0400}
{1192334400 -10800 1 -0300}
{1206846000 -14400 0 -0400}
{1223784000 -10800 1 -0300}
{1237086000 -14400 0 -0400}
{1255233600 -10800 1 -0300}
{1270350000 -14400 0 -0400}
{1286683200 -10800 1 -0300}
{1304823600 -14400 0 -0400}
{1313899200 -10800 1 -0300}
{1335668400 -14400 0 -0400}
{1346558400 -10800 1 -0300}
{1367118000 -14400 0 -0400}
{1378612800 -10800 1 -0300}
{1398567600 -14400 0 -0400}
{1410062400 -10800 1 -0300}
{1463281200 -14400 0 -0400}
{1471147200 -10800 1 -0300}
{1480820400 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Recife.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Recife) {
{-9223372036854775808 -8376 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Recife) {
{-9223372036854775808 -8376 0 LMT}
{-1767217224 -10800 0 -0300}
{-1206957600 -7200 1 -0200}
{-1191362400 -10800 0 -0300}
{-1175374800 -7200 1 -0200}
{-1159826400 -10800 0 -0300}
{-633819600 -7200 1 -0200}
{-622069200 -10800 0 -0300}
{-602283600 -7200 1 -0200}
{-591832800 -10800 0 -0300}
{-570747600 -7200 1 -0200}
{-560210400 -10800 0 -0300}
{-539125200 -7200 1 -0200}
{-531352800 -10800 0 -0300}
{-191365200 -7200 1 -0200}
{-184197600 -10800 0 -0300}
{-155163600 -7200 1 -0200}
{-150069600 -10800 0 -0300}
{-128898000 -7200 1 -0200}
{-121125600 -10800 0 -0300}
{-99954000 -7200 1 -0200}
{-89589600 -10800 0 -0300}
{-68418000 -7200 1 -0200}
{-57967200 -10800 0 -0300}
{499748400 -7200 1 -0200}
{511236000 -10800 0 -0300}
{530593200 -7200 1 -0200}
{540266400 -10800 0 -0300}
{562129200 -7200 1 -0200}
{571197600 -10800 0 -0300}
{592974000 -7200 1 -0200}
{602042400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{634701600 -10800 0 -0300}
{653536800 -10800 0 -0300}
{938660400 -10800 0 -0300}
{938919600 -7200 1 -0200}
{951616800 -10800 0 -0300}
{970974000 -7200 1 -0200}
{971575200 -10800 0 -0300}
{1000350000 -10800 0 -0300}
{1003028400 -7200 1 -0200}
{1013911200 -10800 0 -0300}
{1033437600 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Rio_Branco.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Rio_Branco) {
{-9223372036854775808 -16272 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Rio_Branco) {
{-9223372036854775808 -16272 0 LMT}
{-1767209328 -18000 0 -0500}
{-1206950400 -14400 1 -0400}
{-1191355200 -18000 0 -0500}
{-1175367600 -14400 1 -0400}
{-1159819200 -18000 0 -0500}
{-633812400 -14400 1 -0400}
{-622062000 -18000 0 -0500}
{-602276400 -14400 1 -0400}
{-591825600 -18000 0 -0500}
{-570740400 -14400 1 -0400}
{-560203200 -18000 0 -0500}
{-539118000 -14400 1 -0400}
{-531345600 -18000 0 -0500}
{-191358000 -14400 1 -0400}
{-184190400 -18000 0 -0500}
{-155156400 -14400 1 -0400}
{-150062400 -18000 0 -0500}
{-128890800 -14400 1 -0400}
{-121118400 -18000 0 -0500}
{-99946800 -14400 1 -0400}
{-89582400 -18000 0 -0500}
{-68410800 -14400 1 -0400}
{-57960000 -18000 0 -0500}
{499755600 -14400 1 -0400}
{511243200 -18000 0 -0500}
{530600400 -14400 1 -0400}
{540273600 -18000 0 -0500}
{562136400 -14400 1 -0400}
{571204800 -18000 0 -0500}
{590040000 -18000 0 -0500}
{1214283600 -14400 0 -0400}
{1384056000 -18000 0 -0500}
}
|
Changes to library/tzdata/America/Santarem.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santarem) {
{-9223372036854775808 -13128 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santarem) {
{-9223372036854775808 -13128 0 LMT}
{-1767212472 -14400 0 -0400}
{-1206954000 -10800 1 -0300}
{-1191358800 -14400 0 -0400}
{-1175371200 -10800 1 -0300}
{-1159822800 -14400 0 -0400}
{-633816000 -10800 1 -0300}
{-622065600 -14400 0 -0400}
{-602280000 -10800 1 -0300}
{-591829200 -14400 0 -0400}
{-570744000 -10800 1 -0300}
{-560206800 -14400 0 -0400}
{-539121600 -10800 1 -0300}
{-531349200 -14400 0 -0400}
{-191361600 -10800 1 -0300}
{-184194000 -14400 0 -0400}
{-155160000 -10800 1 -0300}
{-150066000 -14400 0 -0400}
{-128894400 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-99950400 -10800 1 -0300}
{-89586000 -14400 0 -0400}
{-68414400 -10800 1 -0300}
{-57963600 -14400 0 -0400}
{499752000 -10800 1 -0300}
{511239600 -14400 0 -0400}
{530596800 -10800 1 -0300}
{540270000 -14400 0 -0400}
{562132800 -10800 1 -0300}
{571201200 -14400 0 -0400}
{590036400 -14400 0 -0400}
{1214280000 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Santiago.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santiago) {
{-9223372036854775808 -16965 0 LMT}
{-2524504635 -16965 0 SMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santiago) {
{-9223372036854775808 -16965 0 LMT}
{-2524504635 -16965 0 SMT}
{-1892661435 -18000 0 -0500}
{-1688410800 -16965 0 SMT}
{-1619205435 -14400 0 -0400}
{-1593806400 -16965 0 SMT}
{-1335986235 -18000 0 -0500}
{-1335985200 -14400 1 -0400}
{-1317585600 -18000 0 -0500}
{-1304362800 -14400 1 -0400}
{-1286049600 -18000 0 -0500}
{-1272826800 -14400 1 -0400}
{-1254513600 -18000 0 -0500}
{-1241290800 -14400 1 -0400}
{-1222977600 -18000 0 -0500}
{-1209754800 -14400 1 -0400}
{-1191355200 -18000 0 -0500}
{-1178132400 -14400 0 -0400}
{-870552000 -18000 0 -0500}
{-865278000 -14400 0 -0400}
{-740520000 -10800 1 -0300}
{-736635600 -14400 1 -0400}
{-718056000 -18000 0 -0500}
{-713649600 -14400 0 -0400}
{-36619200 -10800 1 -0300}
{-23922000 -14400 0 -0400}
{-3355200 -10800 1 -0300}
{7527600 -14400 0 -0400}
{24465600 -10800 1 -0300}
{37767600 -14400 0 -0400}
{55915200 -10800 1 -0300}
{69217200 -14400 0 -0400}
{87969600 -10800 1 -0300}
{100666800 -14400 0 -0400}
{118209600 -10800 1 -0300}
{132116400 -14400 0 -0400}
{150868800 -10800 1 -0300}
{163566000 -14400 0 -0400}
{182318400 -10800 1 -0300}
{195620400 -14400 0 -0400}
{213768000 -10800 1 -0300}
{227070000 -14400 0 -0400}
{245217600 -10800 1 -0300}
{258519600 -14400 0 -0400}
{277272000 -10800 1 -0300}
{289969200 -14400 0 -0400}
{308721600 -10800 1 -0300}
{321418800 -14400 0 -0400}
{340171200 -10800 1 -0300}
{353473200 -14400 0 -0400}
{371620800 -10800 1 -0300}
{384922800 -14400 0 -0400}
{403070400 -10800 1 -0300}
{416372400 -14400 0 -0400}
{434520000 -10800 1 -0300}
{447822000 -14400 0 -0400}
{466574400 -10800 1 -0300}
{479271600 -14400 0 -0400}
{498024000 -10800 1 -0300}
{510721200 -14400 0 -0400}
{529473600 -10800 1 -0300}
{545194800 -14400 0 -0400}
{560923200 -10800 1 -0300}
{574225200 -14400 0 -0400}
{592372800 -10800 1 -0300}
{605674800 -14400 0 -0400}
{624427200 -10800 1 -0300}
{637124400 -14400 0 -0400}
{653457600 -10800 1 -0300}
{668574000 -14400 0 -0400}
{687326400 -10800 1 -0300}
{700628400 -14400 0 -0400}
{718776000 -10800 1 -0300}
{732078000 -14400 0 -0400}
{750225600 -10800 1 -0300}
{763527600 -14400 0 -0400}
{781675200 -10800 1 -0300}
{794977200 -14400 0 -0400}
{813729600 -10800 1 -0300}
{826426800 -14400 0 -0400}
{845179200 -10800 1 -0300}
{859690800 -14400 0 -0400}
{876628800 -10800 1 -0300}
{889930800 -14400 0 -0400}
{906868800 -10800 1 -0300}
{923194800 -14400 0 -0400}
{939528000 -10800 1 -0300}
{952830000 -14400 0 -0400}
{971582400 -10800 1 -0300}
{984279600 -14400 0 -0400}
{1003032000 -10800 1 -0300}
{1015729200 -14400 0 -0400}
{1034481600 -10800 1 -0300}
{1047178800 -14400 0 -0400}
{1065931200 -10800 1 -0300}
{1079233200 -14400 0 -0400}
{1097380800 -10800 1 -0300}
{1110682800 -14400 0 -0400}
{1128830400 -10800 1 -0300}
{1142132400 -14400 0 -0400}
{1160884800 -10800 1 -0300}
{1173582000 -14400 0 -0400}
{1192334400 -10800 1 -0300}
{1206846000 -14400 0 -0400}
{1223784000 -10800 1 -0300}
{1237086000 -14400 0 -0400}
{1255233600 -10800 1 -0300}
{1270350000 -14400 0 -0400}
{1286683200 -10800 1 -0300}
{1304823600 -14400 0 -0400}
{1313899200 -10800 1 -0300}
{1335668400 -14400 0 -0400}
{1346558400 -10800 1 -0300}
{1367118000 -14400 0 -0400}
{1378612800 -10800 1 -0300}
{1398567600 -14400 0 -0400}
{1410062400 -10800 1 -0300}
{1463281200 -14400 0 -0400}
{1471147200 -10800 1 -0300}
{1494730800 -14400 0 -0400}
{1502596800 -10800 1 -0300}
{1526180400 -14400 0 -0400}
{1534046400 -10800 1 -0300}
{1554606000 -14400 0 -0400}
{1567915200 -10800 1 -0300}
{1586055600 -14400 0 -0400}
{1599364800 -10800 1 -0300}
{1617505200 -14400 0 -0400}
{1630814400 -10800 1 -0300}
{1648954800 -14400 0 -0400}
{1662868800 -10800 1 -0300}
{1680404400 -14400 0 -0400}
{1693713600 -10800 1 -0300}
{1712458800 -14400 0 -0400}
{1725768000 -10800 1 -0300}
{1743908400 -14400 0 -0400}
{1757217600 -10800 1 -0300}
{1775358000 -14400 0 -0400}
{1788667200 -10800 1 -0300}
{1806807600 -14400 0 -0400}
{1820116800 -10800 1 -0300}
{1838257200 -14400 0 -0400}
{1851566400 -10800 1 -0300}
{1870311600 -14400 0 -0400}
{1883016000 -10800 1 -0300}
{1901761200 -14400 0 -0400}
{1915070400 -10800 1 -0300}
{1933210800 -14400 0 -0400}
{1946520000 -10800 1 -0300}
{1964660400 -14400 0 -0400}
{1977969600 -10800 1 -0300}
{1996110000 -14400 0 -0400}
{2009419200 -10800 1 -0300}
{2027559600 -14400 0 -0400}
{2040868800 -10800 1 -0300}
{2059614000 -14400 0 -0400}
{2072318400 -10800 1 -0300}
{2091063600 -14400 0 -0400}
{2104372800 -10800 1 -0300}
{2122513200 -14400 0 -0400}
{2135822400 -10800 1 -0300}
{2153962800 -14400 0 -0400}
{2167272000 -10800 1 -0300}
{2185412400 -14400 0 -0400}
{2198721600 -10800 1 -0300}
{2217466800 -14400 0 -0400}
{2230171200 -10800 1 -0300}
{2248916400 -14400 0 -0400}
{2262225600 -10800 1 -0300}
{2280366000 -14400 0 -0400}
{2293675200 -10800 1 -0300}
{2311815600 -14400 0 -0400}
{2325124800 -10800 1 -0300}
{2343265200 -14400 0 -0400}
{2356574400 -10800 1 -0300}
{2374714800 -14400 0 -0400}
{2388024000 -10800 1 -0300}
{2406769200 -14400 0 -0400}
{2419473600 -10800 1 -0300}
{2438218800 -14400 0 -0400}
{2451528000 -10800 1 -0300}
{2469668400 -14400 0 -0400}
{2482977600 -10800 1 -0300}
{2501118000 -14400 0 -0400}
{2514427200 -10800 1 -0300}
{2532567600 -14400 0 -0400}
{2545876800 -10800 1 -0300}
{2564017200 -14400 0 -0400}
{2577326400 -10800 1 -0300}
{2596071600 -14400 0 -0400}
{2609380800 -10800 1 -0300}
{2627521200 -14400 0 -0400}
{2640830400 -10800 1 -0300}
{2658970800 -14400 0 -0400}
{2672280000 -10800 1 -0300}
{2690420400 -14400 0 -0400}
{2703729600 -10800 1 -0300}
{2721870000 -14400 0 -0400}
{2735179200 -10800 1 -0300}
{2753924400 -14400 0 -0400}
{2766628800 -10800 1 -0300}
{2785374000 -14400 0 -0400}
{2798683200 -10800 1 -0300}
{2816823600 -14400 0 -0400}
{2830132800 -10800 1 -0300}
{2848273200 -14400 0 -0400}
{2861582400 -10800 1 -0300}
{2879722800 -14400 0 -0400}
{2893032000 -10800 1 -0300}
{2911172400 -14400 0 -0400}
{2924481600 -10800 1 -0300}
{2943226800 -14400 0 -0400}
{2955931200 -10800 1 -0300}
{2974676400 -14400 0 -0400}
{2987985600 -10800 1 -0300}
{3006126000 -14400 0 -0400}
{3019435200 -10800 1 -0300}
{3037575600 -14400 0 -0400}
{3050884800 -10800 1 -0300}
{3069025200 -14400 0 -0400}
{3082334400 -10800 1 -0300}
{3101079600 -14400 0 -0400}
{3113784000 -10800 1 -0300}
{3132529200 -14400 0 -0400}
{3145838400 -10800 1 -0300}
{3163978800 -14400 0 -0400}
{3177288000 -10800 1 -0300}
{3195428400 -14400 0 -0400}
{3208737600 -10800 1 -0300}
{3226878000 -14400 0 -0400}
{3240187200 -10800 1 -0300}
{3258327600 -14400 0 -0400}
{3271636800 -10800 1 -0300}
{3290382000 -14400 0 -0400}
{3303086400 -10800 1 -0300}
{3321831600 -14400 0 -0400}
{3335140800 -10800 1 -0300}
{3353281200 -14400 0 -0400}
{3366590400 -10800 1 -0300}
{3384730800 -14400 0 -0400}
{3398040000 -10800 1 -0300}
{3416180400 -14400 0 -0400}
{3429489600 -10800 1 -0300}
{3447630000 -14400 0 -0400}
{3460939200 -10800 1 -0300}
{3479684400 -14400 0 -0400}
{3492993600 -10800 1 -0300}
{3511134000 -14400 0 -0400}
{3524443200 -10800 1 -0300}
{3542583600 -14400 0 -0400}
{3555892800 -10800 1 -0300}
{3574033200 -14400 0 -0400}
{3587342400 -10800 1 -0300}
{3605482800 -14400 0 -0400}
{3618792000 -10800 1 -0300}
{3637537200 -14400 0 -0400}
{3650241600 -10800 1 -0300}
{3668986800 -14400 0 -0400}
{3682296000 -10800 1 -0300}
{3700436400 -14400 0 -0400}
{3713745600 -10800 1 -0300}
{3731886000 -14400 0 -0400}
{3745195200 -10800 1 -0300}
{3763335600 -14400 0 -0400}
{3776644800 -10800 1 -0300}
{3794785200 -14400 0 -0400}
{3808094400 -10800 1 -0300}
{3826839600 -14400 0 -0400}
{3839544000 -10800 1 -0300}
{3858289200 -14400 0 -0400}
{3871598400 -10800 1 -0300}
{3889738800 -14400 0 -0400}
{3903048000 -10800 1 -0300}
{3921188400 -14400 0 -0400}
{3934497600 -10800 1 -0300}
{3952638000 -14400 0 -0400}
{3965947200 -10800 1 -0300}
{3984692400 -14400 0 -0400}
{3997396800 -10800 1 -0300}
{4016142000 -14400 0 -0400}
{4029451200 -10800 1 -0300}
{4047591600 -14400 0 -0400}
{4060900800 -10800 1 -0300}
{4079041200 -14400 0 -0400}
{4092350400 -10800 1 -0300}
}
|
Changes to library/tzdata/America/Sao_Paulo.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Sao_Paulo) {
{-9223372036854775808 -11188 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Sao_Paulo) {
{-9223372036854775808 -11188 0 LMT}
{-1767214412 -10800 0 -0300}
{-1206957600 -7200 1 -0200}
{-1191362400 -10800 0 -0300}
{-1175374800 -7200 1 -0200}
{-1159826400 -10800 0 -0300}
{-633819600 -7200 1 -0200}
{-622069200 -10800 0 -0300}
{-602283600 -7200 1 -0200}
{-591832800 -10800 0 -0300}
{-570747600 -7200 1 -0200}
{-560210400 -10800 0 -0300}
{-539125200 -7200 1 -0200}
{-531352800 -10800 0 -0300}
{-195429600 -7200 1 -0200}
{-189381600 -7200 0 -0200}
{-184197600 -10800 0 -0300}
{-155163600 -7200 1 -0200}
{-150069600 -10800 0 -0300}
{-128898000 -7200 1 -0200}
{-121125600 -10800 0 -0300}
{-99954000 -7200 1 -0200}
{-89589600 -10800 0 -0300}
{-68418000 -7200 1 -0200}
{-57967200 -10800 0 -0300}
{499748400 -7200 1 -0200}
{511236000 -10800 0 -0300}
{530593200 -7200 1 -0200}
{540266400 -10800 0 -0300}
{562129200 -7200 1 -0200}
{571197600 -10800 0 -0300}
{592974000 -7200 1 -0200}
{602042400 -10800 0 -0300}
{624423600 -7200 1 -0200}
{634701600 -10800 0 -0300}
{656478000 -7200 1 -0200}
{666756000 -10800 0 -0300}
{687927600 -7200 1 -0200}
{697600800 -10800 0 -0300}
{719982000 -7200 1 -0200}
{728445600 -10800 0 -0300}
{750826800 -7200 1 -0200}
{761709600 -10800 0 -0300}
{782276400 -7200 1 -0200}
{793159200 -10800 0 -0300}
{813726000 -7200 1 -0200}
{824004000 -10800 0 -0300}
{844570800 -7200 1 -0200}
{856058400 -10800 0 -0300}
{876106800 -7200 1 -0200}
{888717600 -10800 0 -0300}
{908074800 -7200 1 -0200}
{919562400 -10800 0 -0300}
{938919600 -7200 1 -0200}
{951616800 -10800 0 -0300}
{970974000 -7200 1 -0200}
{982461600 -10800 0 -0300}
{1003028400 -7200 1 -0200}
{1013911200 -10800 0 -0300}
{1036292400 -7200 1 -0200}
{1045360800 -10800 0 -0300}
{1066532400 -7200 1 -0200}
{1076810400 -10800 0 -0300}
{1099364400 -7200 1 -0200}
{1108864800 -10800 0 -0300}
{1129431600 -7200 1 -0200}
{1140314400 -10800 0 -0300}
{1162695600 -7200 1 -0200}
{1172368800 -10800 0 -0300}
{1192330800 -7200 1 -0200}
{1203213600 -10800 0 -0300}
{1224385200 -7200 1 -0200}
{1234663200 -10800 0 -0300}
{1255834800 -7200 1 -0200}
{1266717600 -10800 0 -0300}
{1287284400 -7200 1 -0200}
{1298167200 -10800 0 -0300}
{1318734000 -7200 1 -0200}
{1330221600 -10800 0 -0300}
{1350788400 -7200 1 -0200}
{1361066400 -10800 0 -0300}
{1382238000 -7200 1 -0200}
{1392516000 -10800 0 -0300}
{1413687600 -7200 1 -0200}
{1424570400 -10800 0 -0300}
{1445137200 -7200 1 -0200}
{1456020000 -10800 0 -0300}
{1476586800 -7200 1 -0200}
{1487469600 -10800 0 -0300}
{1508036400 -7200 1 -0200}
{1518919200 -10800 0 -0300}
{1541300400 -7200 1 -0200}
{1550368800 -10800 0 -0300}
}
|
Changes to library/tzdata/America/Scoresbysund.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Scoresbysund) {
{-9223372036854775808 -5272 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Scoresbysund) {
{-9223372036854775808 -5272 0 LMT}
{-1686090728 -7200 0 -0200}
{323841600 -3600 0 -0100}
{338961600 -7200 0 -0200}
{354679200 0 0 +0000}
{370400400 -3600 0 -0100}
{386125200 0 1 +0000}
{401850000 -3600 0 -0100}
{417574800 0 1 +0000}
{433299600 -3600 0 -0100}
{449024400 0 1 +0000}
{465354000 -3600 0 -0100}
{481078800 0 1 +0000}
{496803600 -3600 0 -0100}
{512528400 0 1 +0000}
{528253200 -3600 0 -0100}
{543978000 0 1 +0000}
{559702800 -3600 0 -0100}
{575427600 0 1 +0000}
{591152400 -3600 0 -0100}
{606877200 0 1 +0000}
{622602000 -3600 0 -0100}
{638326800 0 1 +0000}
{654656400 -3600 0 -0100}
{670381200 0 1 +0000}
{686106000 -3600 0 -0100}
{701830800 0 1 +0000}
{717555600 -3600 0 -0100}
{733280400 0 1 +0000}
{749005200 -3600 0 -0100}
{764730000 0 1 +0000}
{780454800 -3600 0 -0100}
{796179600 0 1 +0000}
{811904400 -3600 0 -0100}
{828234000 0 1 +0000}
{846378000 -3600 0 -0100}
{859683600 0 1 +0000}
{877827600 -3600 0 -0100}
{891133200 0 1 +0000}
{909277200 -3600 0 -0100}
{922582800 0 1 +0000}
{941331600 -3600 0 -0100}
{954032400 0 1 +0000}
{972781200 -3600 0 -0100}
{985482000 0 1 +0000}
{1004230800 -3600 0 -0100}
{1017536400 0 1 +0000}
{1035680400 -3600 0 -0100}
{1048986000 0 1 +0000}
{1067130000 -3600 0 -0100}
{1080435600 0 1 +0000}
{1099184400 -3600 0 -0100}
{1111885200 0 1 +0000}
{1130634000 -3600 0 -0100}
{1143334800 0 1 +0000}
{1162083600 -3600 0 -0100}
{1174784400 0 1 +0000}
{1193533200 -3600 0 -0100}
{1206838800 0 1 +0000}
{1224982800 -3600 0 -0100}
{1238288400 0 1 +0000}
{1256432400 -3600 0 -0100}
{1269738000 0 1 +0000}
{1288486800 -3600 0 -0100}
{1301187600 0 1 +0000}
{1319936400 -3600 0 -0100}
{1332637200 0 1 +0000}
{1351386000 -3600 0 -0100}
{1364691600 0 1 +0000}
{1382835600 -3600 0 -0100}
{1396141200 0 1 +0000}
{1414285200 -3600 0 -0100}
{1427590800 0 1 +0000}
{1445734800 -3600 0 -0100}
{1459040400 0 1 +0000}
{1477789200 -3600 0 -0100}
{1490490000 0 1 +0000}
{1509238800 -3600 0 -0100}
{1521939600 0 1 +0000}
{1540688400 -3600 0 -0100}
{1553994000 0 1 +0000}
{1572138000 -3600 0 -0100}
{1585443600 0 1 +0000}
{1603587600 -3600 0 -0100}
{1616893200 0 1 +0000}
{1635642000 -3600 0 -0100}
{1648342800 0 1 +0000}
{1667091600 -3600 0 -0100}
{1679792400 0 1 +0000}
{1698541200 -3600 0 -0100}
{1711846800 -3600 0 -0100}
{1729990800 -7200 0 -0200}
{1743296400 -3600 1 -0100}
{1761440400 -7200 0 -0200}
{1774746000 -3600 1 -0100}
{1792890000 -7200 0 -0200}
{1806195600 -3600 1 -0100}
{1824944400 -7200 0 -0200}
{1837645200 -3600 1 -0100}
{1856394000 -7200 0 -0200}
{1869094800 -3600 1 -0100}
{1887843600 -7200 0 -0200}
{1901149200 -3600 1 -0100}
{1919293200 -7200 0 -0200}
{1932598800 -3600 1 -0100}
{1950742800 -7200 0 -0200}
{1964048400 -3600 1 -0100}
{1982797200 -7200 0 -0200}
{1995498000 -3600 1 -0100}
{2014246800 -7200 0 -0200}
{2026947600 -3600 1 -0100}
{2045696400 -7200 0 -0200}
{2058397200 -3600 1 -0100}
{2077146000 -7200 0 -0200}
{2090451600 -3600 1 -0100}
{2108595600 -7200 0 -0200}
{2121901200 -3600 1 -0100}
{2140045200 -7200 0 -0200}
{2153350800 -3600 1 -0100}
{2172099600 -7200 0 -0200}
{2184800400 -3600 1 -0100}
{2203549200 -7200 0 -0200}
{2216250000 -3600 1 -0100}
{2234998800 -7200 0 -0200}
{2248304400 -3600 1 -0100}
{2266448400 -7200 0 -0200}
{2279754000 -3600 1 -0100}
{2297898000 -7200 0 -0200}
{2311203600 -3600 1 -0100}
{2329347600 -7200 0 -0200}
{2342653200 -3600 1 -0100}
{2361402000 -7200 0 -0200}
{2374102800 -3600 1 -0100}
{2392851600 -7200 0 -0200}
{2405552400 -3600 1 -0100}
{2424301200 -7200 0 -0200}
{2437606800 -3600 1 -0100}
{2455750800 -7200 0 -0200}
{2469056400 -3600 1 -0100}
{2487200400 -7200 0 -0200}
{2500506000 -3600 1 -0100}
{2519254800 -7200 0 -0200}
{2531955600 -3600 1 -0100}
{2550704400 -7200 0 -0200}
{2563405200 -3600 1 -0100}
{2582154000 -7200 0 -0200}
{2595459600 -3600 1 -0100}
{2613603600 -7200 0 -0200}
{2626909200 -3600 1 -0100}
{2645053200 -7200 0 -0200}
{2658358800 -3600 1 -0100}
{2676502800 -7200 0 -0200}
{2689808400 -3600 1 -0100}
{2708557200 -7200 0 -0200}
{2721258000 -3600 1 -0100}
{2740006800 -7200 0 -0200}
{2752707600 -3600 1 -0100}
{2771456400 -7200 0 -0200}
{2784762000 -3600 1 -0100}
{2802906000 -7200 0 -0200}
{2816211600 -3600 1 -0100}
{2834355600 -7200 0 -0200}
{2847661200 -3600 1 -0100}
{2866410000 -7200 0 -0200}
{2879110800 -3600 1 -0100}
{2897859600 -7200 0 -0200}
{2910560400 -3600 1 -0100}
{2929309200 -7200 0 -0200}
{2942010000 -3600 1 -0100}
{2960758800 -7200 0 -0200}
{2974064400 -3600 1 -0100}
{2992208400 -7200 0 -0200}
{3005514000 -3600 1 -0100}
{3023658000 -7200 0 -0200}
{3036963600 -3600 1 -0100}
{3055712400 -7200 0 -0200}
{3068413200 -3600 1 -0100}
{3087162000 -7200 0 -0200}
{3099862800 -3600 1 -0100}
{3118611600 -7200 0 -0200}
{3131917200 -3600 1 -0100}
{3150061200 -7200 0 -0200}
{3163366800 -3600 1 -0100}
{3181510800 -7200 0 -0200}
{3194816400 -3600 1 -0100}
{3212960400 -7200 0 -0200}
{3226266000 -3600 1 -0100}
{3245014800 -7200 0 -0200}
{3257715600 -3600 1 -0100}
{3276464400 -7200 0 -0200}
{3289165200 -3600 1 -0100}
{3307914000 -7200 0 -0200}
{3321219600 -3600 1 -0100}
{3339363600 -7200 0 -0200}
{3352669200 -3600 1 -0100}
{3370813200 -7200 0 -0200}
{3384118800 -3600 1 -0100}
{3402867600 -7200 0 -0200}
{3415568400 -3600 1 -0100}
{3434317200 -7200 0 -0200}
{3447018000 -3600 1 -0100}
{3465766800 -7200 0 -0200}
{3479072400 -3600 1 -0100}
{3497216400 -7200 0 -0200}
{3510522000 -3600 1 -0100}
{3528666000 -7200 0 -0200}
{3541971600 -3600 1 -0100}
{3560115600 -7200 0 -0200}
{3573421200 -3600 1 -0100}
{3592170000 -7200 0 -0200}
{3604870800 -3600 1 -0100}
{3623619600 -7200 0 -0200}
{3636320400 -3600 1 -0100}
{3655069200 -7200 0 -0200}
{3668374800 -3600 1 -0100}
{3686518800 -7200 0 -0200}
{3699824400 -3600 1 -0100}
{3717968400 -7200 0 -0200}
{3731274000 -3600 1 -0100}
{3750022800 -7200 0 -0200}
{3762723600 -3600 1 -0100}
{3781472400 -7200 0 -0200}
{3794173200 -3600 1 -0100}
{3812922000 -7200 0 -0200}
{3825622800 -3600 1 -0100}
{3844371600 -7200 0 -0200}
{3857677200 -3600 1 -0100}
{3875821200 -7200 0 -0200}
{3889126800 -3600 1 -0100}
{3907270800 -7200 0 -0200}
{3920576400 -3600 1 -0100}
{3939325200 -7200 0 -0200}
{3952026000 -3600 1 -0100}
{3970774800 -7200 0 -0200}
{3983475600 -3600 1 -0100}
{4002224400 -7200 0 -0200}
{4015530000 -3600 1 -0100}
{4033674000 -7200 0 -0200}
{4046979600 -3600 1 -0100}
{4065123600 -7200 0 -0200}
{4078429200 -3600 1 -0100}
{4096573200 -7200 0 -0200}
}
|
Changes to library/tzdata/America/Tijuana.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Tijuana) {
{-9223372036854775808 -28084 0 LMT}
{-1514739600 -25200 0 MST}
{-1451667600 -28800 0 PST}
| | | > > > > > > | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Tijuana) {
{-9223372036854775808 -28084 0 LMT}
{-1514739600 -25200 0 MST}
{-1451667600 -28800 0 PST}
{-1343145600 -25200 0 MST}
{-1234803600 -28800 0 PST}
{-1222963200 -25200 1 PDT}
{-1207242000 -28800 0 PST}
{-873820800 -25200 1 PWT}
{-769395600 -25200 1 PPT}
{-761418000 -28800 0 PST}
{-686073600 -25200 1 PDT}
{-661539600 -28800 0 PST}
{-620755200 -25200 1 PDT}
{-608144400 -28800 0 PST}
{-589384800 -25200 1 PDT}
{-576082800 -28800 0 PST}
{-557935200 -25200 1 PDT}
{-544633200 -28800 0 PST}
{-504892800 -28800 0 PST}
{-495039600 -25200 1 PDT}
{-481734000 -28800 0 PST}
{-463590000 -25200 1 PDT}
{-450284400 -28800 0 PST}
{-431535600 -25200 1 PDT}
{-418230000 -28800 0 PST}
|
| ︙ | ︙ |
Changes to library/tzdata/Antarctica/Casey.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Casey) {
{-9223372036854775808 0 0 -00}
| | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Casey) {
{-9223372036854775808 0 0 -00}
{-31536000 28800 0 +0800}
{1255802400 39600 0 +1100}
{1267714800 28800 0 +0800}
{1319738400 39600 0 +1100}
{1329843600 28800 0 +0800}
{1477065600 39600 0 +1100}
{1520701200 28800 0 +0800}
{1538856000 39600 0 +1100}
{1552752000 28800 0 +0800}
{1570129200 39600 0 +1100}
{1583596800 28800 0 +0800}
{1601740860 39600 0 +1100}
{1615640400 28800 0 +0800}
{1633190460 39600 0 +1100}
{1647090000 28800 0 +0800}
{1664640060 39600 0 +1100}
{1678291200 28800 0 +0800}
}
|
Changes to library/tzdata/Antarctica/Davis.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Davis) {
{-9223372036854775808 0 0 -00}
| | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Davis) {
{-9223372036854775808 0 0 -00}
{-409190400 25200 0 +0700}
{-163062000 0 0 -00}
{-28857600 25200 0 +0700}
{1255806000 18000 0 +0500}
{1268251200 25200 0 +0700}
{1319742000 18000 0 +0500}
{1329854400 25200 0 +0700}
}
|
Changes to library/tzdata/Antarctica/Mawson.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Mawson) {
{-9223372036854775808 0 0 -00}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Mawson) {
{-9223372036854775808 0 0 -00}
{-501206400 21600 0 +0600}
{1255809600 18000 0 +0500}
}
|
Changes to library/tzdata/Antarctica/Palmer.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Palmer) {
{-9223372036854775808 0 0 -00}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Palmer) {
{-9223372036854775808 0 0 -00}
{-157766400 -14400 0 -0400}
{-152654400 -14400 0 -0400}
{-132955200 -10800 1 -0300}
{-121122000 -14400 0 -0400}
{-101419200 -10800 1 -0300}
{-86821200 -14400 0 -0400}
{-71092800 -10800 1 -0300}
{-54766800 -14400 0 -0400}
{-39038400 -10800 1 -0300}
{-23317200 -14400 0 -0400}
{-7588800 -10800 0 -0300}
{128142000 -7200 1 -0200}
{136605600 -10800 0 -0300}
{389070000 -14400 0 -0400}
{403070400 -10800 1 -0300}
{416372400 -14400 0 -0400}
{434520000 -10800 1 -0300}
{447822000 -14400 0 -0400}
{466574400 -10800 1 -0300}
{479271600 -14400 0 -0400}
{498024000 -10800 1 -0300}
{510721200 -14400 0 -0400}
{529473600 -10800 1 -0300}
{545194800 -14400 0 -0400}
{560923200 -10800 1 -0300}
{574225200 -14400 0 -0400}
{592372800 -10800 1 -0300}
{605674800 -14400 0 -0400}
{624427200 -10800 1 -0300}
{637124400 -14400 0 -0400}
{653457600 -10800 1 -0300}
{668574000 -14400 0 -0400}
{687326400 -10800 1 -0300}
{700628400 -14400 0 -0400}
{718776000 -10800 1 -0300}
{732078000 -14400 0 -0400}
{750225600 -10800 1 -0300}
{763527600 -14400 0 -0400}
{781675200 -10800 1 -0300}
{794977200 -14400 0 -0400}
{813729600 -10800 1 -0300}
{826426800 -14400 0 -0400}
{845179200 -10800 1 -0300}
{859690800 -14400 0 -0400}
{876628800 -10800 1 -0300}
{889930800 -14400 0 -0400}
{906868800 -10800 1 -0300}
{923194800 -14400 0 -0400}
{939528000 -10800 1 -0300}
{952830000 -14400 0 -0400}
{971582400 -10800 1 -0300}
{984279600 -14400 0 -0400}
{1003032000 -10800 1 -0300}
{1015729200 -14400 0 -0400}
{1034481600 -10800 1 -0300}
{1047178800 -14400 0 -0400}
{1065931200 -10800 1 -0300}
{1079233200 -14400 0 -0400}
{1097380800 -10800 1 -0300}
{1110682800 -14400 0 -0400}
{1128830400 -10800 1 -0300}
{1142132400 -14400 0 -0400}
{1160884800 -10800 1 -0300}
{1173582000 -14400 0 -0400}
{1192334400 -10800 1 -0300}
{1206846000 -14400 0 -0400}
{1223784000 -10800 1 -0300}
{1237086000 -14400 0 -0400}
{1255233600 -10800 1 -0300}
{1270350000 -14400 0 -0400}
{1286683200 -10800 1 -0300}
{1304823600 -14400 0 -0400}
{1313899200 -10800 1 -0300}
{1335668400 -14400 0 -0400}
{1346558400 -10800 1 -0300}
{1367118000 -14400 0 -0400}
{1378612800 -10800 1 -0300}
{1398567600 -14400 0 -0400}
{1410062400 -10800 1 -0300}
{1463281200 -14400 0 -0400}
{1471147200 -10800 1 -0300}
{1480820400 -10800 0 -0300}
}
|
Changes to library/tzdata/Antarctica/Rothera.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Rothera) {
{-9223372036854775808 0 0 -00}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Rothera) {
{-9223372036854775808 0 0 -00}
{218246400 -10800 0 -0300}
}
|
Changes to library/tzdata/Antarctica/Vostok.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Vostok) {
{-9223372036854775808 0 0 -00}
| | | | | 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 +0700}
{760035600 0 0 -00}
{783648000 25200 0 +0700}
{1702839600 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Almaty.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Almaty) {
{-9223372036854775808 18468 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Almaty) {
{-9223372036854775808 18468 0 LMT}
{-1441170468 18000 0 +0500}
{-1247547600 21600 0 +0600}
{354909600 25200 1 +0700}
{370717200 21600 0 +0600}
{386445600 25200 1 +0700}
{402253200 21600 0 +0600}
{417981600 25200 1 +0700}
{433789200 21600 0 +0600}
{449604000 25200 1 +0700}
{465336000 21600 0 +0600}
{481060800 25200 1 +0700}
{496785600 21600 0 +0600}
{512510400 25200 1 +0700}
{528235200 21600 0 +0600}
{543960000 25200 1 +0700}
{559684800 21600 0 +0600}
{575409600 25200 1 +0700}
{591134400 21600 0 +0600}
{606859200 25200 1 +0700}
{622584000 21600 0 +0600}
{638308800 25200 1 +0700}
{654638400 21600 0 +0600}
{670363200 18000 0 +0500}
{670366800 21600 1 +0600}
{686091600 18000 0 +0500}
{695768400 21600 0 +0600}
{701812800 25200 1 +0700}
{717537600 21600 0 +0600}
{733262400 25200 1 +0700}
{748987200 21600 0 +0600}
{764712000 25200 1 +0700}
{780436800 21600 0 +0600}
{796161600 25200 1 +0700}
{811886400 21600 0 +0600}
{828216000 25200 1 +0700}
{846360000 21600 0 +0600}
{859665600 25200 1 +0700}
{877809600 21600 0 +0600}
{891115200 25200 1 +0700}
{909259200 21600 0 +0600}
{922564800 25200 1 +0700}
{941313600 21600 0 +0600}
{954014400 25200 1 +0700}
{972763200 21600 0 +0600}
{985464000 25200 1 +0700}
{1004212800 21600 0 +0600}
{1017518400 25200 1 +0700}
{1035662400 21600 0 +0600}
{1048968000 25200 1 +0700}
{1067112000 21600 0 +0600}
{1080417600 25200 1 +0700}
{1099166400 21600 0 +0600}
{1709229600 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Amman.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
{1553810400 10800 1 EEST}
{1571954400 7200 0 EET}
{1585260000 10800 1 EEST}
{1604008800 7200 0 EET}
{1616709600 10800 1 EEST}
{1635458400 7200 0 EET}
{1645740000 10800 1 EEST}
| | | 84 85 86 87 88 89 90 91 92 |
{1553810400 10800 1 EEST}
{1571954400 7200 0 EET}
{1585260000 10800 1 EEST}
{1604008800 7200 0 EET}
{1616709600 10800 1 EEST}
{1635458400 7200 0 EET}
{1645740000 10800 1 EEST}
{1666908000 10800 0 +0300}
}
|
Changes to library/tzdata/Asia/Anadyr.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Anadyr) {
{-9223372036854775808 42596 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Anadyr) {
{-9223372036854775808 42596 0 LMT}
{-1441194596 43200 0 +1200}
{-1247572800 46800 0 +1300}
{354884400 50400 1 +1400}
{370692000 46800 0 +1300}
{386420400 43200 0 +1200}
{386424000 46800 1 +1300}
{402231600 43200 0 +1200}
{417960000 46800 1 +1300}
{433767600 43200 0 +1200}
{449582400 46800 1 +1300}
{465314400 43200 0 +1200}
{481039200 46800 1 +1300}
{496764000 43200 0 +1200}
{512488800 46800 1 +1300}
{528213600 43200 0 +1200}
{543938400 46800 1 +1300}
{559663200 43200 0 +1200}
{575388000 46800 1 +1300}
{591112800 43200 0 +1200}
{606837600 46800 1 +1300}
{622562400 43200 0 +1200}
{638287200 46800 1 +1300}
{654616800 43200 0 +1200}
{670341600 39600 0 +1100}
{670345200 43200 1 +1200}
{686070000 39600 0 +1100}
{695746800 43200 0 +1200}
{701791200 46800 1 +1300}
{717516000 43200 0 +1200}
{733240800 46800 1 +1300}
{748965600 43200 0 +1200}
{764690400 46800 1 +1300}
{780415200 43200 0 +1200}
{796140000 46800 1 +1300}
{811864800 43200 0 +1200}
{828194400 46800 1 +1300}
{846338400 43200 0 +1200}
{859644000 46800 1 +1300}
{877788000 43200 0 +1200}
{891093600 46800 1 +1300}
{909237600 43200 0 +1200}
{922543200 46800 1 +1300}
{941292000 43200 0 +1200}
{953992800 46800 1 +1300}
{972741600 43200 0 +1200}
{985442400 46800 1 +1300}
{1004191200 43200 0 +1200}
{1017496800 46800 1 +1300}
{1035640800 43200 0 +1200}
{1048946400 46800 1 +1300}
{1067090400 43200 0 +1200}
{1080396000 46800 1 +1300}
{1099144800 43200 0 +1200}
{1111845600 46800 1 +1300}
{1130594400 43200 0 +1200}
{1143295200 46800 1 +1300}
{1162044000 43200 0 +1200}
{1174744800 46800 1 +1300}
{1193493600 43200 0 +1200}
{1206799200 46800 1 +1300}
{1224943200 43200 0 +1200}
{1238248800 46800 1 +1300}
{1256392800 43200 0 +1200}
{1269698400 39600 0 +1100}
{1269702000 43200 1 +1200}
{1288450800 39600 0 +1100}
{1301151600 43200 0 +1200}
}
|
Changes to library/tzdata/Asia/Aqtau.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtau) {
{-9223372036854775808 12064 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtau) {
{-9223372036854775808 12064 0 LMT}
{-1441164064 14400 0 +0400}
{-1247544000 18000 0 +0500}
{370724400 21600 0 +0600}
{386445600 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 14400 0 +0400}
{670370400 18000 1 +0500}
{686095200 14400 0 +0400}
{695772000 18000 0 +0500}
{701816400 21600 1 +0600}
{717541200 18000 0 +0500}
{733266000 21600 1 +0600}
{748990800 18000 0 +0500}
{764715600 21600 1 +0600}
{780440400 18000 0 +0500}
{780444000 14400 0 +0400}
{796168800 18000 1 +0500}
{811893600 14400 0 +0400}
{828223200 18000 1 +0500}
{846367200 14400 0 +0400}
{859672800 18000 1 +0500}
{877816800 14400 0 +0400}
{891122400 18000 1 +0500}
{909266400 14400 0 +0400}
{922572000 18000 1 +0500}
{941320800 14400 0 +0400}
{954021600 18000 1 +0500}
{972770400 14400 0 +0400}
{985471200 18000 1 +0500}
{1004220000 14400 0 +0400}
{1017525600 18000 1 +0500}
{1035669600 14400 0 +0400}
{1048975200 18000 1 +0500}
{1067119200 14400 0 +0400}
{1080424800 18000 1 +0500}
{1099173600 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Aqtobe.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtobe) {
{-9223372036854775808 13720 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Aqtobe) {
{-9223372036854775808 13720 0 LMT}
{-1441165720 14400 0 +0400}
{-1247544000 18000 0 +0500}
{354913200 21600 1 +0600}
{370720800 21600 0 +0600}
{386445600 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 14400 0 +0400}
{670370400 18000 1 +0500}
{686095200 14400 0 +0400}
{695772000 18000 0 +0500}
{701816400 21600 1 +0600}
{717541200 18000 0 +0500}
{733266000 21600 1 +0600}
{748990800 18000 0 +0500}
{764715600 21600 1 +0600}
{780440400 18000 0 +0500}
{796165200 21600 1 +0600}
{811890000 18000 0 +0500}
{828219600 21600 1 +0600}
{846363600 18000 0 +0500}
{859669200 21600 1 +0600}
{877813200 18000 0 +0500}
{891118800 21600 1 +0600}
{909262800 18000 0 +0500}
{922568400 21600 1 +0600}
{941317200 18000 0 +0500}
{954018000 21600 1 +0600}
{972766800 18000 0 +0500}
{985467600 21600 1 +0600}
{1004216400 18000 0 +0500}
{1017522000 21600 1 +0600}
{1035666000 18000 0 +0500}
{1048971600 21600 1 +0600}
{1067115600 18000 0 +0500}
{1080421200 21600 1 +0600}
{1099170000 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Ashgabat.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ashgabat) {
{-9223372036854775808 14012 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ashgabat) {
{-9223372036854775808 14012 0 LMT}
{-1441166012 14400 0 +0400}
{-1247544000 18000 0 +0500}
{354913200 21600 1 +0600}
{370720800 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 14400 0 +0400}
{670370400 18000 1 +0500}
{686095200 14400 0 +0400}
{695772000 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Atyrau.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Atyrau) {
{-9223372036854775808 12464 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Atyrau) {
{-9223372036854775808 12464 0 LMT}
{-1441164464 10800 0 +0300}
{-1247540400 18000 0 +0500}
{370724400 21600 0 +0600}
{386445600 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 14400 0 +0400}
{670370400 18000 1 +0500}
{686095200 14400 0 +0400}
{695772000 18000 0 +0500}
{701816400 21600 1 +0600}
{717541200 18000 0 +0500}
{733266000 21600 1 +0600}
{748990800 18000 0 +0500}
{764715600 21600 1 +0600}
{780440400 18000 0 +0500}
{796165200 21600 1 +0600}
{811890000 18000 0 +0500}
{828219600 21600 1 +0600}
{846363600 18000 0 +0500}
{859669200 21600 1 +0600}
{877813200 18000 0 +0500}
{891118800 21600 1 +0600}
{909262800 18000 0 +0500}
{922568400 14400 0 +0400}
{922572000 18000 1 +0500}
{941320800 14400 0 +0400}
{954021600 18000 1 +0500}
{972770400 14400 0 +0400}
{985471200 18000 1 +0500}
{1004220000 14400 0 +0400}
{1017525600 18000 1 +0500}
{1035669600 14400 0 +0400}
{1048975200 18000 1 +0500}
{1067119200 14400 0 +0400}
{1080424800 18000 1 +0500}
{1099173600 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Baghdad.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baghdad) {
{-9223372036854775808 10660 0 LMT}
{-2524532260 10656 0 BMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baghdad) {
{-9223372036854775808 10660 0 LMT}
{-2524532260 10656 0 BMT}
{-1641005856 10800 0 +0300}
{389048400 14400 0 +0400}
{402264000 10800 0 +0300}
{417906000 14400 1 +0400}
{433800000 10800 0 +0300}
{449614800 14400 1 +0400}
{465422400 10800 0 +0300}
{481150800 14400 1 +0400}
{496792800 10800 0 +0300}
{512517600 14400 1 +0400}
{528242400 10800 0 +0300}
{543967200 14400 1 +0400}
{559692000 10800 0 +0300}
{575416800 14400 1 +0400}
{591141600 10800 0 +0300}
{606866400 14400 1 +0400}
{622591200 10800 0 +0300}
{638316000 14400 1 +0400}
{654645600 10800 0 +0300}
{670464000 14400 1 +0400}
{686275200 10800 0 +0300}
{702086400 14400 1 +0400}
{717897600 10800 0 +0300}
{733622400 14400 1 +0400}
{749433600 10800 0 +0300}
{765158400 14400 1 +0400}
{780969600 10800 0 +0300}
{796694400 14400 1 +0400}
{812505600 10800 0 +0300}
{828316800 14400 1 +0400}
{844128000 10800 0 +0300}
{859852800 14400 1 +0400}
{875664000 10800 0 +0300}
{891388800 14400 1 +0400}
{907200000 10800 0 +0300}
{922924800 14400 1 +0400}
{938736000 10800 0 +0300}
{954547200 14400 1 +0400}
{970358400 10800 0 +0300}
{986083200 14400 1 +0400}
{1001894400 10800 0 +0300}
{1017619200 14400 1 +0400}
{1033430400 10800 0 +0300}
{1049155200 14400 1 +0400}
{1064966400 10800 0 +0300}
{1080777600 14400 1 +0400}
{1096588800 10800 0 +0300}
{1112313600 14400 1 +0400}
{1128124800 10800 0 +0300}
{1143849600 14400 1 +0400}
{1159660800 10800 0 +0300}
{1175385600 14400 1 +0400}
{1191196800 10800 0 +0300}
}
|
Changes to library/tzdata/Asia/Baku.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baku) {
{-9223372036854775808 11964 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Baku) {
{-9223372036854775808 11964 0 LMT}
{-1441163964 10800 0 +0300}
{-405140400 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 18000 1 +0500}
{591141600 14400 0 +0400}
{606866400 18000 1 +0500}
{622591200 14400 0 +0400}
{638316000 18000 1 +0500}
{654645600 14400 0 +0400}
{670370400 10800 0 +0300}
{670374000 14400 1 +0400}
{686098800 10800 0 +0300}
{701823600 14400 1 +0400}
{717548400 14400 0 +0400}
{820440000 14400 0 +0400}
{828234000 18000 1 +0500}
{846378000 14400 0 +0400}
{852062400 14400 0 +0400}
{859680000 18000 1 +0500}
{877824000 14400 0 +0400}
{891129600 18000 1 +0500}
{909273600 14400 0 +0400}
{922579200 18000 1 +0500}
{941328000 14400 0 +0400}
{954028800 18000 1 +0500}
{972777600 14400 0 +0400}
{985478400 18000 1 +0500}
{1004227200 14400 0 +0400}
{1017532800 18000 1 +0500}
{1035676800 14400 0 +0400}
{1048982400 18000 1 +0500}
{1067126400 14400 0 +0400}
{1080432000 18000 1 +0500}
{1099180800 14400 0 +0400}
{1111881600 18000 1 +0500}
{1130630400 14400 0 +0400}
{1143331200 18000 1 +0500}
{1162080000 14400 0 +0400}
{1174780800 18000 1 +0500}
{1193529600 14400 0 +0400}
{1206835200 18000 1 +0500}
{1224979200 14400 0 +0400}
{1238284800 18000 1 +0500}
{1256428800 14400 0 +0400}
{1269734400 18000 1 +0500}
{1288483200 14400 0 +0400}
{1301184000 18000 1 +0500}
{1319932800 14400 0 +0400}
{1332633600 18000 1 +0500}
{1351382400 14400 0 +0400}
{1364688000 18000 1 +0500}
{1382832000 14400 0 +0400}
{1396137600 18000 1 +0500}
{1414281600 14400 0 +0400}
{1427587200 18000 1 +0500}
{1445731200 14400 0 +0400}
}
|
Changes to library/tzdata/Asia/Bangkok.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Bangkok) {
{-9223372036854775808 24124 0 LMT}
{-2840164924 24124 0 BMT}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Bangkok) {
{-9223372036854775808 24124 0 LMT}
{-2840164924 24124 0 BMT}
{-1570084924 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Barnaul.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Barnaul) {
{-9223372036854775808 20100 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Barnaul) {
{-9223372036854775808 20100 0 LMT}
{-1579844100 21600 0 +0600}
{-1247551200 25200 0 +0700}
{354906000 28800 1 +0800}
{370713600 25200 0 +0700}
{386442000 28800 1 +0800}
{402249600 25200 0 +0700}
{417978000 28800 1 +0800}
{433785600 25200 0 +0700}
{449600400 28800 1 +0800}
{465332400 25200 0 +0700}
{481057200 28800 1 +0800}
{496782000 25200 0 +0700}
{512506800 28800 1 +0800}
{528231600 25200 0 +0700}
{543956400 28800 1 +0800}
{559681200 25200 0 +0700}
{575406000 28800 1 +0800}
{591130800 25200 0 +0700}
{606855600 28800 1 +0800}
{622580400 25200 0 +0700}
{638305200 28800 1 +0800}
{654634800 25200 0 +0700}
{670359600 21600 0 +0600}
{670363200 25200 1 +0700}
{686088000 21600 0 +0600}
{695764800 25200 0 +0700}
{701809200 28800 1 +0800}
{717534000 25200 0 +0700}
{733258800 28800 1 +0800}
{748983600 25200 0 +0700}
{764708400 28800 1 +0800}
{780433200 25200 0 +0700}
{796158000 28800 1 +0800}
{801594000 25200 0 +0700}
{811886400 21600 0 +0600}
{828216000 25200 1 +0700}
{846360000 21600 0 +0600}
{859665600 25200 1 +0700}
{877809600 21600 0 +0600}
{891115200 25200 1 +0700}
{909259200 21600 0 +0600}
{922564800 25200 1 +0700}
{941313600 21600 0 +0600}
{954014400 25200 1 +0700}
{972763200 21600 0 +0600}
{985464000 25200 1 +0700}
{1004212800 21600 0 +0600}
{1017518400 25200 1 +0700}
{1035662400 21600 0 +0600}
{1048968000 25200 1 +0700}
{1067112000 21600 0 +0600}
{1080417600 25200 1 +0700}
{1099166400 21600 0 +0600}
{1111867200 25200 1 +0700}
{1130616000 21600 0 +0600}
{1143316800 25200 1 +0700}
{1162065600 21600 0 +0600}
{1174766400 25200 1 +0700}
{1193515200 21600 0 +0600}
{1206820800 25200 1 +0700}
{1224964800 21600 0 +0600}
{1238270400 25200 1 +0700}
{1256414400 21600 0 +0600}
{1269720000 25200 1 +0700}
{1288468800 21600 0 +0600}
{1301169600 25200 0 +0700}
{1414263600 21600 0 +0600}
{1459022400 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Bishkek.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Bishkek) {
{-9223372036854775808 17904 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Bishkek) {
{-9223372036854775808 17904 0 LMT}
{-1441169904 18000 0 +0500}
{-1247547600 21600 0 +0600}
{354909600 25200 1 +0700}
{370717200 21600 0 +0600}
{386445600 25200 1 +0700}
{402253200 21600 0 +0600}
{417981600 25200 1 +0700}
{433789200 21600 0 +0600}
{449604000 25200 1 +0700}
{465336000 21600 0 +0600}
{481060800 25200 1 +0700}
{496785600 21600 0 +0600}
{512510400 25200 1 +0700}
{528235200 21600 0 +0600}
{543960000 25200 1 +0700}
{559684800 21600 0 +0600}
{575409600 25200 1 +0700}
{591134400 21600 0 +0600}
{606859200 25200 1 +0700}
{622584000 21600 0 +0600}
{638308800 25200 1 +0700}
{654638400 21600 0 +0600}
{670363200 18000 0 +0500}
{670366800 21600 1 +0600}
{683586000 18000 0 +0500}
{703018800 21600 1 +0600}
{717530400 18000 0 +0500}
{734468400 21600 1 +0600}
{748980000 18000 0 +0500}
{765918000 21600 1 +0600}
{780429600 18000 0 +0500}
{797367600 21600 1 +0600}
{811879200 18000 0 +0500}
{828817200 21600 1 +0600}
{843933600 18000 0 +0500}
{859671000 21600 1 +0600}
{877811400 18000 0 +0500}
{891120600 21600 1 +0600}
{909261000 18000 0 +0500}
{922570200 21600 1 +0600}
{941315400 18000 0 +0500}
{954019800 21600 1 +0600}
{972765000 18000 0 +0500}
{985469400 21600 1 +0600}
{1004214600 18000 0 +0500}
{1017523800 21600 1 +0600}
{1035664200 18000 0 +0500}
{1048973400 21600 1 +0600}
{1067113800 18000 0 +0500}
{1080423000 21600 1 +0600}
{1099168200 18000 0 +0500}
{1111872600 21600 1 +0600}
{1123783200 21600 0 +0600}
}
|
Changes to library/tzdata/Asia/Chita.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Chita) {
{-9223372036854775808 27232 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Chita) {
{-9223372036854775808 27232 0 LMT}
{-1579419232 28800 0 +0800}
{-1247558400 32400 0 +0900}
{354898800 36000 1 +1000}
{370706400 32400 0 +0900}
{386434800 36000 1 +1000}
{402242400 32400 0 +0900}
{417970800 36000 1 +1000}
{433778400 32400 0 +0900}
{449593200 36000 1 +1000}
{465325200 32400 0 +0900}
{481050000 36000 1 +1000}
{496774800 32400 0 +0900}
{512499600 36000 1 +1000}
{528224400 32400 0 +0900}
{543949200 36000 1 +1000}
{559674000 32400 0 +0900}
{575398800 36000 1 +1000}
{591123600 32400 0 +0900}
{606848400 36000 1 +1000}
{622573200 32400 0 +0900}
{638298000 36000 1 +1000}
{654627600 32400 0 +0900}
{670352400 28800 0 +0800}
{670356000 32400 1 +0900}
{686080800 28800 0 +0800}
{695757600 32400 0 +0900}
{701802000 36000 1 +1000}
{717526800 32400 0 +0900}
{733251600 36000 1 +1000}
{748976400 32400 0 +0900}
{764701200 36000 1 +1000}
{780426000 32400 0 +0900}
{796150800 36000 1 +1000}
{811875600 32400 0 +0900}
{828205200 36000 1 +1000}
{846349200 32400 0 +0900}
{859654800 36000 1 +1000}
{877798800 32400 0 +0900}
{891104400 36000 1 +1000}
{909248400 32400 0 +0900}
{922554000 36000 1 +1000}
{941302800 32400 0 +0900}
{954003600 36000 1 +1000}
{972752400 32400 0 +0900}
{985453200 36000 1 +1000}
{1004202000 32400 0 +0900}
{1017507600 36000 1 +1000}
{1035651600 32400 0 +0900}
{1048957200 36000 1 +1000}
{1067101200 32400 0 +0900}
{1080406800 36000 1 +1000}
{1099155600 32400 0 +0900}
{1111856400 36000 1 +1000}
{1130605200 32400 0 +0900}
{1143306000 36000 1 +1000}
{1162054800 32400 0 +0900}
{1174755600 36000 1 +1000}
{1193504400 32400 0 +0900}
{1206810000 36000 1 +1000}
{1224954000 32400 0 +0900}
{1238259600 36000 1 +1000}
{1256403600 32400 0 +0900}
{1269709200 36000 1 +1000}
{1288458000 32400 0 +0900}
{1301158800 36000 0 +1000}
{1414252800 28800 0 +0800}
{1459015200 32400 0 +0900}
}
|
Changes to library/tzdata/Asia/Choibalsan.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Ulaanbaatar)]} {
LoadTimeZoneFile Asia/Ulaanbaatar
}
set TZData(:Asia/Choibalsan) $TZData(:Asia/Ulaanbaatar)
|
Changes to library/tzdata/Asia/Colombo.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Colombo) {
{-9223372036854775808 19164 0 LMT}
{-2840159964 19172 0 MMT}
{-2019705572 19800 0 +0530}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Colombo) {
{-9223372036854775808 19164 0 LMT}
{-2840159964 19172 0 MMT}
{-2019705572 19800 0 +0530}
{-883287000 21600 1 +0600}
{-862639200 23400 1 +0630}
{-764051400 19800 0 +0530}
{832962600 23400 0 +0630}
{846266400 21600 0 +0600}
{1145039400 19800 0 +0530}
}
|
Changes to library/tzdata/Asia/Damascus.
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
{1553810400 10800 1 EEST}
{1571950800 7200 0 EET}
{1585260000 10800 1 EEST}
{1604005200 7200 0 EET}
{1616709600 10800 1 EEST}
{1635454800 7200 0 EET}
{1648159200 10800 1 EEST}
| | | 118 119 120 121 122 123 124 125 126 |
{1553810400 10800 1 EEST}
{1571950800 7200 0 EET}
{1585260000 10800 1 EEST}
{1604005200 7200 0 EET}
{1616709600 10800 1 EEST}
{1635454800 7200 0 EET}
{1648159200 10800 1 EEST}
{1666908000 10800 0 +0300}
}
|
Changes to library/tzdata/Asia/Dhaka.
1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dhaka) {
{-9223372036854775808 21700 0 LMT}
{-2524543300 21200 0 HMT}
{-891582800 23400 0 +0630}
{-872058600 19800 0 +0530}
{-862637400 23400 0 +0630}
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dhaka) {
{-9223372036854775808 21700 0 LMT}
{-2524543300 21200 0 HMT}
{-891582800 23400 0 +0630}
{-872058600 19800 0 +0530}
{-862637400 23400 0 +0630}
{-576138600 21600 0 +0600}
{1230746400 21600 0 +0600}
{1245430800 25200 1 +0700}
{1262278800 21600 0 +0600}
}
|
Changes to library/tzdata/Asia/Dili.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dili) {
{-9223372036854775808 30140 0 LMT}
| | | | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dili) {
{-9223372036854775808 30140 0 LMT}
{-1830412800 28800 0 +0800}
{-879152400 32400 0 +0900}
{199897200 28800 0 +0800}
{969120000 32400 0 +0900}
}
|
Changes to library/tzdata/Asia/Dubai.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dubai) {
{-9223372036854775808 13272 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dubai) {
{-9223372036854775808 13272 0 LMT}
{-1577936472 14400 0 +0400}
}
|
Changes to library/tzdata/Asia/Dushanbe.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dushanbe) {
{-9223372036854775808 16512 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Dushanbe) {
{-9223372036854775808 16512 0 LMT}
{-1441168512 18000 0 +0500}
{-1247547600 21600 0 +0600}
{354909600 25200 1 +0700}
{370717200 21600 0 +0600}
{386445600 25200 1 +0700}
{402253200 21600 0 +0600}
{417981600 25200 1 +0700}
{433789200 21600 0 +0600}
{449604000 25200 1 +0700}
{465336000 21600 0 +0600}
{481060800 25200 1 +0700}
{496785600 21600 0 +0600}
{512510400 25200 1 +0700}
{528235200 21600 0 +0600}
{543960000 25200 1 +0700}
{559684800 21600 0 +0600}
{575409600 25200 1 +0700}
{591134400 21600 0 +0600}
{606859200 25200 1 +0700}
{622584000 21600 0 +0600}
{638308800 25200 1 +0700}
{654638400 21600 0 +0600}
{670363200 21600 1 +0600}
{684363600 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Famagusta.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
{1364691600 10800 1 EEST}
{1382835600 7200 0 EET}
{1396141200 10800 1 EEST}
{1414285200 7200 0 EET}
{1427590800 10800 1 EEST}
{1445734800 7200 0 EET}
{1459040400 10800 1 EEST}
| | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
{1364691600 10800 1 EEST}
{1382835600 7200 0 EET}
{1396141200 10800 1 EEST}
{1414285200 7200 0 EET}
{1427590800 10800 1 EEST}
{1445734800 7200 0 EET}
{1459040400 10800 1 EEST}
{1473285600 10800 0 +0300}
{1509238800 7200 0 EET}
{1521939600 10800 1 EEST}
{1540688400 7200 0 EET}
{1553994000 10800 1 EEST}
{1572138000 7200 0 EET}
{1585443600 10800 1 EEST}
{1603587600 7200 0 EET}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Ho_Chi_Minh.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ho_Chi_Minh) {
{-9223372036854775808 25590 0 LMT}
{-2004073590 25590 0 PLMT}
| | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ho_Chi_Minh) {
{-9223372036854775808 25590 0 LMT}
{-2004073590 25590 0 PLMT}
{-1851577590 25200 0 +0700}
{-852105600 28800 0 +0800}
{-782643600 32400 0 +0900}
{-767869200 25200 0 +0700}
{-718095600 28800 0 +0800}
{-457772400 25200 0 +0700}
{-315648000 28800 0 +0800}
{171820800 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Hovd.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hovd) {
{-9223372036854775808 21996 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hovd) {
{-9223372036854775808 21996 0 LMT}
{-2032927596 21600 0 +0600}
{252439200 25200 0 +0700}
{417978000 28800 1 +0800}
{433785600 25200 0 +0700}
{449600400 28800 1 +0800}
{465321600 25200 0 +0700}
{481050000 28800 1 +0800}
{496771200 25200 0 +0700}
{512499600 28800 1 +0800}
{528220800 25200 0 +0700}
{543949200 28800 1 +0800}
{559670400 25200 0 +0700}
{575398800 28800 1 +0800}
{591120000 25200 0 +0700}
{606848400 28800 1 +0800}
{622569600 25200 0 +0700}
{638298000 28800 1 +0800}
{654624000 25200 0 +0700}
{670352400 28800 1 +0800}
{686073600 25200 0 +0700}
{701802000 28800 1 +0800}
{717523200 25200 0 +0700}
{733251600 28800 1 +0800}
{748972800 25200 0 +0700}
{764701200 28800 1 +0800}
{780422400 25200 0 +0700}
{796150800 28800 1 +0800}
{811872000 25200 0 +0700}
{828205200 28800 1 +0800}
{843926400 25200 0 +0700}
{859654800 28800 1 +0800}
{875376000 25200 0 +0700}
{891104400 28800 1 +0800}
{906825600 25200 0 +0700}
{988398000 28800 1 +0800}
{1001700000 25200 0 +0700}
{1017428400 28800 1 +0800}
{1033149600 25200 0 +0700}
{1048878000 28800 1 +0800}
{1064599200 25200 0 +0700}
{1080327600 28800 1 +0800}
{1096048800 25200 0 +0700}
{1111777200 28800 1 +0800}
{1127498400 25200 0 +0700}
{1143226800 28800 1 +0800}
{1159552800 25200 0 +0700}
{1427482800 28800 1 +0800}
{1443196800 25200 0 +0700}
{1458932400 28800 1 +0800}
{1474646400 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Irkutsk.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Irkutsk) {
{-9223372036854775808 25025 0 LMT}
{-2840165825 25025 0 IMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Irkutsk) {
{-9223372036854775808 25025 0 LMT}
{-2840165825 25025 0 IMT}
{-1575874625 25200 0 +0700}
{-1247554800 28800 0 +0800}
{354902400 32400 1 +0900}
{370710000 28800 0 +0800}
{386438400 32400 1 +0900}
{402246000 28800 0 +0800}
{417974400 32400 1 +0900}
{433782000 28800 0 +0800}
{449596800 32400 1 +0900}
{465328800 28800 0 +0800}
{481053600 32400 1 +0900}
{496778400 28800 0 +0800}
{512503200 32400 1 +0900}
{528228000 28800 0 +0800}
{543952800 32400 1 +0900}
{559677600 28800 0 +0800}
{575402400 32400 1 +0900}
{591127200 28800 0 +0800}
{606852000 32400 1 +0900}
{622576800 28800 0 +0800}
{638301600 32400 1 +0900}
{654631200 28800 0 +0800}
{670356000 25200 0 +0700}
{670359600 28800 1 +0800}
{686084400 25200 0 +0700}
{695761200 28800 0 +0800}
{701805600 32400 1 +0900}
{717530400 28800 0 +0800}
{733255200 32400 1 +0900}
{748980000 28800 0 +0800}
{764704800 32400 1 +0900}
{780429600 28800 0 +0800}
{796154400 32400 1 +0900}
{811879200 28800 0 +0800}
{828208800 32400 1 +0900}
{846352800 28800 0 +0800}
{859658400 32400 1 +0900}
{877802400 28800 0 +0800}
{891108000 32400 1 +0900}
{909252000 28800 0 +0800}
{922557600 32400 1 +0900}
{941306400 28800 0 +0800}
{954007200 32400 1 +0900}
{972756000 28800 0 +0800}
{985456800 32400 1 +0900}
{1004205600 28800 0 +0800}
{1017511200 32400 1 +0900}
{1035655200 28800 0 +0800}
{1048960800 32400 1 +0900}
{1067104800 28800 0 +0800}
{1080410400 32400 1 +0900}
{1099159200 28800 0 +0800}
{1111860000 32400 1 +0900}
{1130608800 28800 0 +0800}
{1143309600 32400 1 +0900}
{1162058400 28800 0 +0800}
{1174759200 32400 1 +0900}
{1193508000 28800 0 +0800}
{1206813600 32400 1 +0900}
{1224957600 28800 0 +0800}
{1238263200 32400 1 +0900}
{1256407200 28800 0 +0800}
{1269712800 32400 1 +0900}
{1288461600 28800 0 +0800}
{1301162400 32400 0 +0900}
{1414256400 28800 0 +0800}
}
|
Changes to library/tzdata/Asia/Jakarta.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Jakarta) {
{-9223372036854775808 25632 0 LMT}
{-3231299232 25632 0 BMT}
{-1451719200 26400 0 +0720}
{-1172906400 27000 0 +0730}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Jakarta) {
{-9223372036854775808 25632 0 LMT}
{-3231299232 25632 0 BMT}
{-1451719200 26400 0 +0720}
{-1172906400 27000 0 +0730}
{-876641400 32400 0 +0900}
{-766054800 27000 0 +0730}
{-683883000 28800 0 +0800}
{-620812800 27000 0 +0730}
{-189415800 25200 0 WIB}
}
|
Changes to library/tzdata/Asia/Jayapura.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Jayapura) {
{-9223372036854775808 33768 0 LMT}
| | | 1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Jayapura) {
{-9223372036854775808 33768 0 LMT}
{-1172913768 32400 0 +0900}
{-799491600 34200 0 +0930}
{-189423000 32400 0 WIT}
}
|
Changes to library/tzdata/Asia/Kabul.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kabul) {
{-9223372036854775808 16608 0 LMT}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kabul) {
{-9223372036854775808 16608 0 LMT}
{-2524538208 14400 0 +0400}
{-788932800 16200 0 +0430}
}
|
Changes to library/tzdata/Asia/Kamchatka.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kamchatka) {
{-9223372036854775808 38076 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kamchatka) {
{-9223372036854775808 38076 0 LMT}
{-1487759676 39600 0 +1100}
{-1247569200 43200 0 +1200}
{354888000 46800 1 +1300}
{370695600 43200 0 +1200}
{386424000 46800 1 +1300}
{402231600 43200 0 +1200}
{417960000 46800 1 +1300}
{433767600 43200 0 +1200}
{449582400 46800 1 +1300}
{465314400 43200 0 +1200}
{481039200 46800 1 +1300}
{496764000 43200 0 +1200}
{512488800 46800 1 +1300}
{528213600 43200 0 +1200}
{543938400 46800 1 +1300}
{559663200 43200 0 +1200}
{575388000 46800 1 +1300}
{591112800 43200 0 +1200}
{606837600 46800 1 +1300}
{622562400 43200 0 +1200}
{638287200 46800 1 +1300}
{654616800 43200 0 +1200}
{670341600 39600 0 +1100}
{670345200 43200 1 +1200}
{686070000 39600 0 +1100}
{695746800 43200 0 +1200}
{701791200 46800 1 +1300}
{717516000 43200 0 +1200}
{733240800 46800 1 +1300}
{748965600 43200 0 +1200}
{764690400 46800 1 +1300}
{780415200 43200 0 +1200}
{796140000 46800 1 +1300}
{811864800 43200 0 +1200}
{828194400 46800 1 +1300}
{846338400 43200 0 +1200}
{859644000 46800 1 +1300}
{877788000 43200 0 +1200}
{891093600 46800 1 +1300}
{909237600 43200 0 +1200}
{922543200 46800 1 +1300}
{941292000 43200 0 +1200}
{953992800 46800 1 +1300}
{972741600 43200 0 +1200}
{985442400 46800 1 +1300}
{1004191200 43200 0 +1200}
{1017496800 46800 1 +1300}
{1035640800 43200 0 +1200}
{1048946400 46800 1 +1300}
{1067090400 43200 0 +1200}
{1080396000 46800 1 +1300}
{1099144800 43200 0 +1200}
{1111845600 46800 1 +1300}
{1130594400 43200 0 +1200}
{1143295200 46800 1 +1300}
{1162044000 43200 0 +1200}
{1174744800 46800 1 +1300}
{1193493600 43200 0 +1200}
{1206799200 46800 1 +1300}
{1224943200 43200 0 +1200}
{1238248800 46800 1 +1300}
{1256392800 43200 0 +1200}
{1269698400 39600 0 +1100}
{1269702000 43200 1 +1200}
{1288450800 39600 0 +1100}
{1301151600 43200 0 +1200}
}
|
Changes to library/tzdata/Asia/Karachi.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Karachi) {
{-9223372036854775808 16092 0 LMT}
{-1988166492 19800 0 +0530}
{-862637400 23400 1 +0630}
{-764145000 19800 0 +0530}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Karachi) {
{-9223372036854775808 16092 0 LMT}
{-1988166492 19800 0 +0530}
{-862637400 23400 1 +0630}
{-764145000 19800 0 +0530}
{-576135000 18000 0 +0500}
{38775600 18000 0 PKT}
{1018119600 21600 1 PKST}
{1033840800 18000 0 PKT}
{1212260400 21600 1 PKST}
{1225476000 18000 0 PKT}
{1239735600 21600 1 PKST}
{1257012000 18000 0 PKT}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Khandyga.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Khandyga) {
{-9223372036854775808 32533 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Khandyga) {
{-9223372036854775808 32533 0 LMT}
{-1579424533 28800 0 +0800}
{-1247558400 32400 0 +0900}
{354898800 36000 1 +1000}
{370706400 32400 0 +0900}
{386434800 36000 1 +1000}
{402242400 32400 0 +0900}
{417970800 36000 1 +1000}
{433778400 32400 0 +0900}
{449593200 36000 1 +1000}
{465325200 32400 0 +0900}
{481050000 36000 1 +1000}
{496774800 32400 0 +0900}
{512499600 36000 1 +1000}
{528224400 32400 0 +0900}
{543949200 36000 1 +1000}
{559674000 32400 0 +0900}
{575398800 36000 1 +1000}
{591123600 32400 0 +0900}
{606848400 36000 1 +1000}
{622573200 32400 0 +0900}
{638298000 36000 1 +1000}
{654627600 32400 0 +0900}
{670352400 28800 0 +0800}
{670356000 32400 1 +0900}
{686080800 28800 0 +0800}
{695757600 32400 0 +0900}
{701802000 36000 1 +1000}
{717526800 32400 0 +0900}
{733251600 36000 1 +1000}
{748976400 32400 0 +0900}
{764701200 36000 1 +1000}
{780426000 32400 0 +0900}
{796150800 36000 1 +1000}
{811875600 32400 0 +0900}
{828205200 36000 1 +1000}
{846349200 32400 0 +0900}
{859654800 36000 1 +1000}
{877798800 32400 0 +0900}
{891104400 36000 1 +1000}
{909248400 32400 0 +0900}
{922554000 36000 1 +1000}
{941302800 32400 0 +0900}
{954003600 36000 1 +1000}
{972752400 32400 0 +0900}
{985453200 36000 1 +1000}
{1004202000 32400 0 +0900}
{1017507600 36000 1 +1000}
{1035651600 32400 0 +0900}
{1048957200 36000 1 +1000}
{1067101200 32400 0 +0900}
{1072882800 36000 0 +1000}
{1080403200 39600 1 +1100}
{1099152000 36000 0 +1000}
{1111852800 39600 1 +1100}
{1130601600 36000 0 +1000}
{1143302400 39600 1 +1100}
{1162051200 36000 0 +1000}
{1174752000 39600 1 +1100}
{1193500800 36000 0 +1000}
{1206806400 39600 1 +1100}
{1224950400 36000 0 +1000}
{1238256000 39600 1 +1100}
{1256400000 36000 0 +1000}
{1269705600 39600 1 +1100}
{1288454400 36000 0 +1000}
{1301155200 39600 0 +1100}
{1315832400 36000 0 +1000}
{1414252800 32400 0 +0900}
}
|
Changes to library/tzdata/Asia/Krasnoyarsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Krasnoyarsk) {
{-9223372036854775808 22286 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Krasnoyarsk) {
{-9223372036854775808 22286 0 LMT}
{-1577513486 21600 0 +0600}
{-1247551200 25200 0 +0700}
{354906000 28800 1 +0800}
{370713600 25200 0 +0700}
{386442000 28800 1 +0800}
{402249600 25200 0 +0700}
{417978000 28800 1 +0800}
{433785600 25200 0 +0700}
{449600400 28800 1 +0800}
{465332400 25200 0 +0700}
{481057200 28800 1 +0800}
{496782000 25200 0 +0700}
{512506800 28800 1 +0800}
{528231600 25200 0 +0700}
{543956400 28800 1 +0800}
{559681200 25200 0 +0700}
{575406000 28800 1 +0800}
{591130800 25200 0 +0700}
{606855600 28800 1 +0800}
{622580400 25200 0 +0700}
{638305200 28800 1 +0800}
{654634800 25200 0 +0700}
{670359600 21600 0 +0600}
{670363200 25200 1 +0700}
{686088000 21600 0 +0600}
{695764800 25200 0 +0700}
{701809200 28800 1 +0800}
{717534000 25200 0 +0700}
{733258800 28800 1 +0800}
{748983600 25200 0 +0700}
{764708400 28800 1 +0800}
{780433200 25200 0 +0700}
{796158000 28800 1 +0800}
{811882800 25200 0 +0700}
{828212400 28800 1 +0800}
{846356400 25200 0 +0700}
{859662000 28800 1 +0800}
{877806000 25200 0 +0700}
{891111600 28800 1 +0800}
{909255600 25200 0 +0700}
{922561200 28800 1 +0800}
{941310000 25200 0 +0700}
{954010800 28800 1 +0800}
{972759600 25200 0 +0700}
{985460400 28800 1 +0800}
{1004209200 25200 0 +0700}
{1017514800 28800 1 +0800}
{1035658800 25200 0 +0700}
{1048964400 28800 1 +0800}
{1067108400 25200 0 +0700}
{1080414000 28800 1 +0800}
{1099162800 25200 0 +0700}
{1111863600 28800 1 +0800}
{1130612400 25200 0 +0700}
{1143313200 28800 1 +0800}
{1162062000 25200 0 +0700}
{1174762800 28800 1 +0800}
{1193511600 25200 0 +0700}
{1206817200 28800 1 +0800}
{1224961200 25200 0 +0700}
{1238266800 28800 1 +0800}
{1256410800 25200 0 +0700}
{1269716400 28800 1 +0800}
{1288465200 25200 0 +0700}
{1301166000 28800 0 +0800}
{1414260000 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Kuching.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kuching) {
{-9223372036854775808 26480 0 LMT}
{-1383463280 27000 0 +0730}
| | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Kuching) {
{-9223372036854775808 26480 0 LMT}
{-1383463280 27000 0 +0730}
{-1167636600 28800 0 +0800}
{-1082448000 30000 1 +0820}
{-1074586800 28800 0 +0800}
{-1050825600 30000 1 +0820}
{-1042964400 28800 0 +0800}
{-1019289600 30000 1 +0820}
{-1011428400 28800 0 +0800}
{-987753600 30000 1 +0820}
{-979892400 28800 0 +0800}
{-956217600 30000 1 +0820}
{-948356400 28800 0 +0800}
{-924595200 30000 1 +0820}
{-916734000 28800 0 +0800}
{-893059200 30000 1 +0820}
{-885198000 28800 0 +0800}
{-879667200 32400 0 +0900}
{-767005200 28800 0 +0800}
}
|
Changes to library/tzdata/Asia/Macau.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Macau) {
{-9223372036854775808 27250 0 LMT}
{-2056692850 28800 0 CST}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Macau) {
{-9223372036854775808 27250 0 LMT}
{-2056692850 28800 0 CST}
{-884509200 32400 0 +0900}
{-873280800 36000 1 +1000}
{-855918000 32400 0 +0900}
{-841744800 36000 1 +1000}
{-828529200 32400 0 +0900}
{-765363600 28800 0 CT}
{-747046800 32400 1 CDT}
{-733827600 28800 0 CST}
{-716461200 32400 1 CDT}
{-697021200 28800 0 CST}
{-683715600 32400 1 CDT}
{-667990800 28800 0 CST}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Magadan.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Magadan) {
{-9223372036854775808 36192 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Magadan) {
{-9223372036854775808 36192 0 LMT}
{-1441188192 36000 0 +1000}
{-1247565600 39600 0 +1100}
{354891600 43200 1 +1200}
{370699200 39600 0 +1100}
{386427600 43200 1 +1200}
{402235200 39600 0 +1100}
{417963600 43200 1 +1200}
{433771200 39600 0 +1100}
{449586000 43200 1 +1200}
{465318000 39600 0 +1100}
{481042800 43200 1 +1200}
{496767600 39600 0 +1100}
{512492400 43200 1 +1200}
{528217200 39600 0 +1100}
{543942000 43200 1 +1200}
{559666800 39600 0 +1100}
{575391600 43200 1 +1200}
{591116400 39600 0 +1100}
{606841200 43200 1 +1200}
{622566000 39600 0 +1100}
{638290800 43200 1 +1200}
{654620400 39600 0 +1100}
{670345200 36000 0 +1000}
{670348800 39600 1 +1100}
{686073600 36000 0 +1000}
{695750400 39600 0 +1100}
{701794800 43200 1 +1200}
{717519600 39600 0 +1100}
{733244400 43200 1 +1200}
{748969200 39600 0 +1100}
{764694000 43200 1 +1200}
{780418800 39600 0 +1100}
{796143600 43200 1 +1200}
{811868400 39600 0 +1100}
{828198000 43200 1 +1200}
{846342000 39600 0 +1100}
{859647600 43200 1 +1200}
{877791600 39600 0 +1100}
{891097200 43200 1 +1200}
{909241200 39600 0 +1100}
{922546800 43200 1 +1200}
{941295600 39600 0 +1100}
{953996400 43200 1 +1200}
{972745200 39600 0 +1100}
{985446000 43200 1 +1200}
{1004194800 39600 0 +1100}
{1017500400 43200 1 +1200}
{1035644400 39600 0 +1100}
{1048950000 43200 1 +1200}
{1067094000 39600 0 +1100}
{1080399600 43200 1 +1200}
{1099148400 39600 0 +1100}
{1111849200 43200 1 +1200}
{1130598000 39600 0 +1100}
{1143298800 43200 1 +1200}
{1162047600 39600 0 +1100}
{1174748400 43200 1 +1200}
{1193497200 39600 0 +1100}
{1206802800 43200 1 +1200}
{1224946800 39600 0 +1100}
{1238252400 43200 1 +1200}
{1256396400 39600 0 +1100}
{1269702000 43200 1 +1200}
{1288450800 39600 0 +1100}
{1301151600 43200 0 +1200}
{1414245600 36000 0 +1000}
{1461427200 39600 0 +1100}
}
|
Changes to library/tzdata/Asia/Makassar.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Makassar) {
{-9223372036854775808 28656 0 LMT}
{-1577951856 28656 0 MMT}
| | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Makassar) {
{-9223372036854775808 28656 0 LMT}
{-1577951856 28656 0 MMT}
{-1172908656 28800 0 +0800}
{-880272000 32400 0 +0900}
{-766054800 28800 0 WITA}
}
|
Changes to library/tzdata/Asia/Novokuznetsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Novokuznetsk) {
{-9223372036854775808 20928 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Novokuznetsk) {
{-9223372036854775808 20928 0 LMT}
{-1441259328 21600 0 +0600}
{-1247551200 25200 0 +0700}
{354906000 28800 1 +0800}
{370713600 25200 0 +0700}
{386442000 28800 1 +0800}
{402249600 25200 0 +0700}
{417978000 28800 1 +0800}
{433785600 25200 0 +0700}
{449600400 28800 1 +0800}
{465332400 25200 0 +0700}
{481057200 28800 1 +0800}
{496782000 25200 0 +0700}
{512506800 28800 1 +0800}
{528231600 25200 0 +0700}
{543956400 28800 1 +0800}
{559681200 25200 0 +0700}
{575406000 28800 1 +0800}
{591130800 25200 0 +0700}
{606855600 28800 1 +0800}
{622580400 25200 0 +0700}
{638305200 28800 1 +0800}
{654634800 25200 0 +0700}
{670359600 21600 0 +0600}
{670363200 25200 1 +0700}
{686088000 21600 0 +0600}
{695764800 25200 0 +0700}
{701809200 28800 1 +0800}
{717534000 25200 0 +0700}
{733258800 28800 1 +0800}
{748983600 25200 0 +0700}
{764708400 28800 1 +0800}
{780433200 25200 0 +0700}
{796158000 28800 1 +0800}
{811882800 25200 0 +0700}
{828212400 28800 1 +0800}
{846356400 25200 0 +0700}
{859662000 28800 1 +0800}
{877806000 25200 0 +0700}
{891111600 28800 1 +0800}
{909255600 25200 0 +0700}
{922561200 28800 1 +0800}
{941310000 25200 0 +0700}
{954010800 28800 1 +0800}
{972759600 25200 0 +0700}
{985460400 28800 1 +0800}
{1004209200 25200 0 +0700}
{1017514800 28800 1 +0800}
{1035658800 25200 0 +0700}
{1048964400 28800 1 +0800}
{1067108400 25200 0 +0700}
{1080414000 28800 1 +0800}
{1099162800 25200 0 +0700}
{1111863600 28800 1 +0800}
{1130612400 25200 0 +0700}
{1143313200 28800 1 +0800}
{1162062000 25200 0 +0700}
{1174762800 28800 1 +0800}
{1193511600 25200 0 +0700}
{1206817200 28800 1 +0800}
{1224961200 25200 0 +0700}
{1238266800 28800 1 +0800}
{1256410800 25200 0 +0700}
{1269716400 21600 0 +0600}
{1269720000 25200 1 +0700}
{1288468800 21600 0 +0600}
{1301169600 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Novosibirsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Novosibirsk) {
{-9223372036854775808 19900 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Novosibirsk) {
{-9223372036854775808 19900 0 LMT}
{-1579476700 21600 0 +0600}
{-1247551200 25200 0 +0700}
{354906000 28800 1 +0800}
{370713600 25200 0 +0700}
{386442000 28800 1 +0800}
{402249600 25200 0 +0700}
{417978000 28800 1 +0800}
{433785600 25200 0 +0700}
{449600400 28800 1 +0800}
{465332400 25200 0 +0700}
{481057200 28800 1 +0800}
{496782000 25200 0 +0700}
{512506800 28800 1 +0800}
{528231600 25200 0 +0700}
{543956400 28800 1 +0800}
{559681200 25200 0 +0700}
{575406000 28800 1 +0800}
{591130800 25200 0 +0700}
{606855600 28800 1 +0800}
{622580400 25200 0 +0700}
{638305200 28800 1 +0800}
{654634800 25200 0 +0700}
{670359600 21600 0 +0600}
{670363200 25200 1 +0700}
{686088000 21600 0 +0600}
{695764800 25200 0 +0700}
{701809200 28800 1 +0800}
{717534000 25200 0 +0700}
{733258800 28800 1 +0800}
{738090000 25200 0 +0700}
{748987200 21600 0 +0600}
{764712000 25200 1 +0700}
{780436800 21600 0 +0600}
{796161600 25200 1 +0700}
{811886400 21600 0 +0600}
{828216000 25200 1 +0700}
{846360000 21600 0 +0600}
{859665600 25200 1 +0700}
{877809600 21600 0 +0600}
{891115200 25200 1 +0700}
{909259200 21600 0 +0600}
{922564800 25200 1 +0700}
{941313600 21600 0 +0600}
{954014400 25200 1 +0700}
{972763200 21600 0 +0600}
{985464000 25200 1 +0700}
{1004212800 21600 0 +0600}
{1017518400 25200 1 +0700}
{1035662400 21600 0 +0600}
{1048968000 25200 1 +0700}
{1067112000 21600 0 +0600}
{1080417600 25200 1 +0700}
{1099166400 21600 0 +0600}
{1111867200 25200 1 +0700}
{1130616000 21600 0 +0600}
{1143316800 25200 1 +0700}
{1162065600 21600 0 +0600}
{1174766400 25200 1 +0700}
{1193515200 21600 0 +0600}
{1206820800 25200 1 +0700}
{1224964800 21600 0 +0600}
{1238270400 25200 1 +0700}
{1256414400 21600 0 +0600}
{1269720000 25200 1 +0700}
{1288468800 21600 0 +0600}
{1301169600 25200 0 +0700}
{1414263600 21600 0 +0600}
{1469304000 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Omsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Omsk) {
{-9223372036854775808 17610 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Omsk) {
{-9223372036854775808 17610 0 LMT}
{-1582088010 18000 0 +0500}
{-1247547600 21600 0 +0600}
{354909600 25200 1 +0700}
{370717200 21600 0 +0600}
{386445600 25200 1 +0700}
{402253200 21600 0 +0600}
{417981600 25200 1 +0700}
{433789200 21600 0 +0600}
{449604000 25200 1 +0700}
{465336000 21600 0 +0600}
{481060800 25200 1 +0700}
{496785600 21600 0 +0600}
{512510400 25200 1 +0700}
{528235200 21600 0 +0600}
{543960000 25200 1 +0700}
{559684800 21600 0 +0600}
{575409600 25200 1 +0700}
{591134400 21600 0 +0600}
{606859200 25200 1 +0700}
{622584000 21600 0 +0600}
{638308800 25200 1 +0700}
{654638400 21600 0 +0600}
{670363200 18000 0 +0500}
{670366800 21600 1 +0600}
{686091600 18000 0 +0500}
{695768400 21600 0 +0600}
{701812800 25200 1 +0700}
{717537600 21600 0 +0600}
{733262400 25200 1 +0700}
{748987200 21600 0 +0600}
{764712000 25200 1 +0700}
{780436800 21600 0 +0600}
{796161600 25200 1 +0700}
{811886400 21600 0 +0600}
{828216000 25200 1 +0700}
{846360000 21600 0 +0600}
{859665600 25200 1 +0700}
{877809600 21600 0 +0600}
{891115200 25200 1 +0700}
{909259200 21600 0 +0600}
{922564800 25200 1 +0700}
{941313600 21600 0 +0600}
{954014400 25200 1 +0700}
{972763200 21600 0 +0600}
{985464000 25200 1 +0700}
{1004212800 21600 0 +0600}
{1017518400 25200 1 +0700}
{1035662400 21600 0 +0600}
{1048968000 25200 1 +0700}
{1067112000 21600 0 +0600}
{1080417600 25200 1 +0700}
{1099166400 21600 0 +0600}
{1111867200 25200 1 +0700}
{1130616000 21600 0 +0600}
{1143316800 25200 1 +0700}
{1162065600 21600 0 +0600}
{1174766400 25200 1 +0700}
{1193515200 21600 0 +0600}
{1206820800 25200 1 +0700}
{1224964800 21600 0 +0600}
{1238270400 25200 1 +0700}
{1256414400 21600 0 +0600}
{1269720000 25200 1 +0700}
{1288468800 21600 0 +0600}
{1301169600 25200 0 +0700}
{1414263600 21600 0 +0600}
}
|
Changes to library/tzdata/Asia/Oral.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Oral) {
{-9223372036854775808 12324 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Oral) {
{-9223372036854775808 12324 0 LMT}
{-1441164324 10800 0 +0300}
{-1247540400 18000 0 +0500}
{354913200 21600 1 +0600}
{370720800 21600 0 +0600}
{386445600 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 14400 0 +0400}
{606866400 18000 1 +0500}
{622591200 14400 0 +0400}
{638316000 18000 1 +0500}
{654645600 14400 0 +0400}
{670370400 18000 1 +0500}
{686095200 14400 0 +0400}
{701816400 14400 0 +0400}
{701820000 18000 1 +0500}
{717544800 14400 0 +0400}
{733269600 18000 1 +0500}
{748994400 14400 0 +0400}
{764719200 18000 1 +0500}
{780444000 14400 0 +0400}
{796168800 18000 1 +0500}
{811893600 14400 0 +0400}
{828223200 18000 1 +0500}
{846367200 14400 0 +0400}
{859672800 18000 1 +0500}
{877816800 14400 0 +0400}
{891122400 18000 1 +0500}
{909266400 14400 0 +0400}
{922572000 18000 1 +0500}
{941320800 14400 0 +0400}
{954021600 18000 1 +0500}
{972770400 14400 0 +0400}
{985471200 18000 1 +0500}
{1004220000 14400 0 +0400}
{1017525600 18000 1 +0500}
{1035669600 14400 0 +0400}
{1048975200 18000 1 +0500}
{1067119200 14400 0 +0400}
{1080424800 18000 1 +0500}
{1099173600 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Pontianak.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Pontianak) {
{-9223372036854775808 26240 0 LMT}
{-1946186240 26240 0 PMT}
{-1172906240 27000 0 +0730}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Pontianak) {
{-9223372036854775808 26240 0 LMT}
{-1946186240 26240 0 PMT}
{-1172906240 27000 0 +0730}
{-881220600 32400 0 +0900}
{-766054800 27000 0 +0730}
{-683883000 28800 0 +0800}
{-620812800 27000 0 +0730}
{-189415800 28800 0 WITA}
{567964800 25200 0 WIB}
}
|
Changes to library/tzdata/Asia/Qatar.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qatar) {
{-9223372036854775808 12368 0 LMT}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qatar) {
{-9223372036854775808 12368 0 LMT}
{-1577935568 14400 0 +0400}
{76190400 10800 0 +0300}
}
|
Changes to library/tzdata/Asia/Qostanay.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qostanay) {
{-9223372036854775808 15268 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qostanay) {
{-9223372036854775808 15268 0 LMT}
{-1441167268 14400 0 +0400}
{-1247544000 18000 0 +0500}
{354913200 21600 1 +0600}
{370720800 21600 0 +0600}
{386445600 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 14400 0 +0400}
{670370400 18000 1 +0500}
{686095200 14400 0 +0400}
{695772000 18000 0 +0500}
{701816400 21600 1 +0600}
{717541200 18000 0 +0500}
{733266000 21600 1 +0600}
{748990800 18000 0 +0500}
{764715600 21600 1 +0600}
{780440400 18000 0 +0500}
{796165200 21600 1 +0600}
{811890000 18000 0 +0500}
{828219600 21600 1 +0600}
{846363600 18000 0 +0500}
{859669200 21600 1 +0600}
{877813200 18000 0 +0500}
{891118800 21600 1 +0600}
{909262800 18000 0 +0500}
{922568400 21600 1 +0600}
{941317200 18000 0 +0500}
{954018000 21600 1 +0600}
{972766800 18000 0 +0500}
{985467600 21600 1 +0600}
{1004216400 18000 0 +0500}
{1017522000 21600 1 +0600}
{1035666000 18000 0 +0500}
{1048971600 21600 1 +0600}
{1067115600 18000 0 +0500}
{1080421200 21600 1 +0600}
{1099170000 21600 0 +0600}
{1709229600 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Qyzylorda.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qyzylorda) {
{-9223372036854775808 15712 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Qyzylorda) {
{-9223372036854775808 15712 0 LMT}
{-1441167712 14400 0 +0400}
{-1247544000 18000 0 +0500}
{354913200 21600 1 +0600}
{370720800 21600 0 +0600}
{386445600 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 14400 0 +0400}
{670370400 18000 1 +0500}
{701812800 18000 0 +0500}
{701816400 21600 1 +0600}
{717541200 18000 0 +0500}
{733266000 21600 1 +0600}
{748990800 18000 0 +0500}
{764715600 21600 1 +0600}
{780440400 18000 0 +0500}
{796165200 21600 1 +0600}
{811890000 18000 0 +0500}
{828219600 21600 1 +0600}
{846363600 18000 0 +0500}
{859669200 21600 1 +0600}
{877813200 18000 0 +0500}
{891118800 21600 1 +0600}
{909262800 18000 0 +0500}
{922568400 21600 1 +0600}
{941317200 18000 0 +0500}
{954018000 21600 1 +0600}
{972766800 18000 0 +0500}
{985467600 21600 1 +0600}
{1004216400 18000 0 +0500}
{1017522000 21600 1 +0600}
{1035666000 18000 0 +0500}
{1048971600 21600 1 +0600}
{1067115600 18000 0 +0500}
{1080421200 21600 1 +0600}
{1099170000 21600 0 +0600}
{1545328800 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Riyadh.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Riyadh) {
{-9223372036854775808 11212 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Riyadh) {
{-9223372036854775808 11212 0 LMT}
{-719636812 10800 0 +0300}
}
|
Changes to library/tzdata/Asia/Sakhalin.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Sakhalin) {
{-9223372036854775808 34248 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Sakhalin) {
{-9223372036854775808 34248 0 LMT}
{-2031039048 32400 0 +0900}
{-768560400 39600 0 +1100}
{354891600 43200 1 +1200}
{370699200 39600 0 +1100}
{386427600 43200 1 +1200}
{402235200 39600 0 +1100}
{417963600 43200 1 +1200}
{433771200 39600 0 +1100}
{449586000 43200 1 +1200}
{465318000 39600 0 +1100}
{481042800 43200 1 +1200}
{496767600 39600 0 +1100}
{512492400 43200 1 +1200}
{528217200 39600 0 +1100}
{543942000 43200 1 +1200}
{559666800 39600 0 +1100}
{575391600 43200 1 +1200}
{591116400 39600 0 +1100}
{606841200 43200 1 +1200}
{622566000 39600 0 +1100}
{638290800 43200 1 +1200}
{654620400 39600 0 +1100}
{670345200 36000 0 +1000}
{670348800 39600 1 +1100}
{686073600 36000 0 +1000}
{695750400 39600 0 +1100}
{701794800 43200 1 +1200}
{717519600 39600 0 +1100}
{733244400 43200 1 +1200}
{748969200 39600 0 +1100}
{764694000 43200 1 +1200}
{780418800 39600 0 +1100}
{796143600 43200 1 +1200}
{811868400 39600 0 +1100}
{828198000 43200 1 +1200}
{846342000 39600 0 +1100}
{859647600 36000 0 +1000}
{859651200 39600 1 +1100}
{877795200 36000 0 +1000}
{891100800 39600 1 +1100}
{909244800 36000 0 +1000}
{922550400 39600 1 +1100}
{941299200 36000 0 +1000}
{954000000 39600 1 +1100}
{972748800 36000 0 +1000}
{985449600 39600 1 +1100}
{1004198400 36000 0 +1000}
{1017504000 39600 1 +1100}
{1035648000 36000 0 +1000}
{1048953600 39600 1 +1100}
{1067097600 36000 0 +1000}
{1080403200 39600 1 +1100}
{1099152000 36000 0 +1000}
{1111852800 39600 1 +1100}
{1130601600 36000 0 +1000}
{1143302400 39600 1 +1100}
{1162051200 36000 0 +1000}
{1174752000 39600 1 +1100}
{1193500800 36000 0 +1000}
{1206806400 39600 1 +1100}
{1224950400 36000 0 +1000}
{1238256000 39600 1 +1100}
{1256400000 36000 0 +1000}
{1269705600 39600 1 +1100}
{1288454400 36000 0 +1000}
{1301155200 39600 0 +1100}
{1414249200 36000 0 +1000}
{1459008000 39600 0 +1100}
}
|
Changes to library/tzdata/Asia/Samarkand.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Samarkand) {
{-9223372036854775808 16073 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Samarkand) {
{-9223372036854775808 16073 0 LMT}
{-1441168073 14400 0 +0400}
{-1247544000 18000 0 +0500}
{354913200 21600 1 +0600}
{370720800 21600 0 +0600}
{386445600 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 21600 1 +0600}
{686091600 18000 0 +0500}
{694206000 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Singapore.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Singapore) {
{-9223372036854775808 24925 0 LMT}
{-2177477725 24925 0 SMT}
| | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Singapore) {
{-9223372036854775808 24925 0 LMT}
{-2177477725 24925 0 SMT}
{-2038200925 25200 0 +0700}
{-1167634800 26400 1 +0720}
{-1073028000 26400 0 +0720}
{-894180000 27000 0 +0730}
{-879665400 32400 0 +0900}
{-767005200 27000 0 +0730}
{378662400 28800 0 +0800}
}
|
Changes to library/tzdata/Asia/Srednekolymsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Srednekolymsk) {
{-9223372036854775808 36892 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Srednekolymsk) {
{-9223372036854775808 36892 0 LMT}
{-1441188892 36000 0 +1000}
{-1247565600 39600 0 +1100}
{354891600 43200 1 +1200}
{370699200 39600 0 +1100}
{386427600 43200 1 +1200}
{402235200 39600 0 +1100}
{417963600 43200 1 +1200}
{433771200 39600 0 +1100}
{449586000 43200 1 +1200}
{465318000 39600 0 +1100}
{481042800 43200 1 +1200}
{496767600 39600 0 +1100}
{512492400 43200 1 +1200}
{528217200 39600 0 +1100}
{543942000 43200 1 +1200}
{559666800 39600 0 +1100}
{575391600 43200 1 +1200}
{591116400 39600 0 +1100}
{606841200 43200 1 +1200}
{622566000 39600 0 +1100}
{638290800 43200 1 +1200}
{654620400 39600 0 +1100}
{670345200 36000 0 +1000}
{670348800 39600 1 +1100}
{686073600 36000 0 +1000}
{695750400 39600 0 +1100}
{701794800 43200 1 +1200}
{717519600 39600 0 +1100}
{733244400 43200 1 +1200}
{748969200 39600 0 +1100}
{764694000 43200 1 +1200}
{780418800 39600 0 +1100}
{796143600 43200 1 +1200}
{811868400 39600 0 +1100}
{828198000 43200 1 +1200}
{846342000 39600 0 +1100}
{859647600 43200 1 +1200}
{877791600 39600 0 +1100}
{891097200 43200 1 +1200}
{909241200 39600 0 +1100}
{922546800 43200 1 +1200}
{941295600 39600 0 +1100}
{953996400 43200 1 +1200}
{972745200 39600 0 +1100}
{985446000 43200 1 +1200}
{1004194800 39600 0 +1100}
{1017500400 43200 1 +1200}
{1035644400 39600 0 +1100}
{1048950000 43200 1 +1200}
{1067094000 39600 0 +1100}
{1080399600 43200 1 +1200}
{1099148400 39600 0 +1100}
{1111849200 43200 1 +1200}
{1130598000 39600 0 +1100}
{1143298800 43200 1 +1200}
{1162047600 39600 0 +1100}
{1174748400 43200 1 +1200}
{1193497200 39600 0 +1100}
{1206802800 43200 1 +1200}
{1224946800 39600 0 +1100}
{1238252400 43200 1 +1200}
{1256396400 39600 0 +1100}
{1269702000 43200 1 +1200}
{1288450800 39600 0 +1100}
{1301151600 43200 0 +1200}
{1414245600 39600 0 +1100}
}
|
Changes to library/tzdata/Asia/Tashkent.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tashkent) {
{-9223372036854775808 16631 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tashkent) {
{-9223372036854775808 16631 0 LMT}
{-1441168631 18000 0 +0500}
{-1247547600 21600 0 +0600}
{354909600 25200 1 +0700}
{370717200 21600 0 +0600}
{386445600 25200 1 +0700}
{402253200 21600 0 +0600}
{417981600 25200 1 +0700}
{433789200 21600 0 +0600}
{449604000 25200 1 +0700}
{465336000 21600 0 +0600}
{481060800 25200 1 +0700}
{496785600 21600 0 +0600}
{512510400 25200 1 +0700}
{528235200 21600 0 +0600}
{543960000 25200 1 +0700}
{559684800 21600 0 +0600}
{575409600 25200 1 +0700}
{591134400 21600 0 +0600}
{606859200 25200 1 +0700}
{622584000 21600 0 +0600}
{638308800 25200 1 +0700}
{654638400 21600 0 +0600}
{670363200 18000 0 +0500}
{670366800 21600 1 +0600}
{686091600 18000 0 +0500}
{694206000 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Tbilisi.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tbilisi) {
{-9223372036854775808 10751 0 LMT}
{-2840151551 10751 0 TBMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tbilisi) {
{-9223372036854775808 10751 0 LMT}
{-2840151551 10751 0 TBMT}
{-1441162751 10800 0 +0300}
{-405140400 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 18000 1 +0500}
{591141600 14400 0 +0400}
{606866400 18000 1 +0500}
{622591200 14400 0 +0400}
{638316000 18000 1 +0500}
{654645600 14400 0 +0400}
{670370400 10800 0 +0300}
{670374000 14400 1 +0400}
{686098800 10800 0 +0300}
{694213200 10800 0 +0300}
{701816400 14400 1 +0400}
{717537600 10800 0 +0300}
{733266000 14400 1 +0400}
{748987200 10800 0 +0300}
{764715600 14400 1 +0400}
{780440400 14400 0 +0400}
{796161600 18000 1 +0500}
{811882800 14400 0 +0400}
{828216000 18000 1 +0500}
{846360000 18000 1 +0500}
{859662000 18000 0 +0500}
{877806000 14400 0 +0400}
{891115200 18000 1 +0500}
{909255600 14400 0 +0400}
{922564800 18000 1 +0500}
{941310000 14400 0 +0400}
{954014400 18000 1 +0500}
{972759600 14400 0 +0400}
{985464000 18000 1 +0500}
{1004209200 14400 0 +0400}
{1017518400 18000 1 +0500}
{1035658800 14400 0 +0400}
{1048968000 18000 1 +0500}
{1067108400 14400 0 +0400}
{1080417600 18000 1 +0500}
{1088280000 14400 0 +0400}
{1099177200 10800 0 +0300}
{1111878000 14400 0 +0400}
}
|
Changes to library/tzdata/Asia/Tehran.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tehran) {
{-9223372036854775808 12344 0 LMT}
{-1704165944 12344 0 TMT}
{-1090466744 12600 0 +0330}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tehran) {
{-9223372036854775808 12344 0 LMT}
{-1704165944 12344 0 TMT}
{-1090466744 12600 0 +0330}
{227820600 16200 1 +0430}
{246227400 14400 0 +0400}
{259617600 18000 1 +0500}
{271108800 14400 0 +0400}
{283982400 12600 0 +0330}
{296598600 16200 1 +0430}
{306531000 12600 0 +0330}
{322432200 16200 1 +0430}
{338499000 12600 0 +0330}
{673216200 16200 1 +0430}
{685481400 12600 0 +0330}
{701209800 16200 1 +0430}
{717103800 12600 0 +0330}
{732745800 16200 1 +0430}
{748639800 12600 0 +0330}
{764281800 16200 1 +0430}
{780175800 12600 0 +0330}
{795817800 16200 1 +0430}
{811711800 12600 0 +0330}
{827353800 16200 1 +0430}
{843247800 12600 0 +0330}
{858976200 16200 1 +0430}
{874870200 12600 0 +0330}
{890512200 16200 1 +0430}
{906406200 12600 0 +0330}
{922048200 16200 1 +0430}
{937942200 12600 0 +0330}
{953584200 16200 1 +0430}
{969478200 12600 0 +0330}
{985206600 16200 1 +0430}
{1001100600 12600 0 +0330}
{1016742600 16200 1 +0430}
{1032636600 12600 0 +0330}
{1048278600 16200 1 +0430}
{1064172600 12600 0 +0330}
{1079814600 16200 1 +0430}
{1095708600 12600 0 +0330}
{1111437000 16200 1 +0430}
{1127331000 12600 0 +0330}
{1206045000 16200 1 +0430}
{1221939000 12600 0 +0330}
{1237667400 16200 1 +0430}
{1253561400 12600 0 +0330}
{1269203400 16200 1 +0430}
{1285097400 12600 0 +0330}
{1300739400 16200 1 +0430}
{1316633400 12600 0 +0330}
{1332275400 16200 1 +0430}
{1348169400 12600 0 +0330}
{1363897800 16200 1 +0430}
{1379791800 12600 0 +0330}
{1395433800 16200 1 +0430}
{1411327800 12600 0 +0330}
{1426969800 16200 1 +0430}
{1442863800 12600 0 +0330}
{1458505800 16200 1 +0430}
{1474399800 12600 0 +0330}
{1490128200 16200 1 +0430}
{1506022200 12600 0 +0330}
{1521664200 16200 1 +0430}
{1537558200 12600 0 +0330}
{1553200200 16200 1 +0430}
{1569094200 12600 0 +0330}
{1584736200 16200 1 +0430}
{1600630200 12600 0 +0330}
{1616358600 16200 1 +0430}
{1632252600 12600 0 +0330}
{1647894600 16200 1 +0430}
{1663788600 12600 0 +0330}
}
|
Changes to library/tzdata/Asia/Thimphu.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Thimphu) {
{-9223372036854775808 21516 0 LMT}
{-706341516 19800 0 +0530}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Thimphu) {
{-9223372036854775808 21516 0 LMT}
{-706341516 19800 0 +0530}
{560025000 21600 0 +0600}
}
|
Changes to library/tzdata/Asia/Tomsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tomsk) {
{-9223372036854775808 20391 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tomsk) {
{-9223372036854775808 20391 0 LMT}
{-1578807591 21600 0 +0600}
{-1247551200 25200 0 +0700}
{354906000 28800 1 +0800}
{370713600 25200 0 +0700}
{386442000 28800 1 +0800}
{402249600 25200 0 +0700}
{417978000 28800 1 +0800}
{433785600 25200 0 +0700}
{449600400 28800 1 +0800}
{465332400 25200 0 +0700}
{481057200 28800 1 +0800}
{496782000 25200 0 +0700}
{512506800 28800 1 +0800}
{528231600 25200 0 +0700}
{543956400 28800 1 +0800}
{559681200 25200 0 +0700}
{575406000 28800 1 +0800}
{591130800 25200 0 +0700}
{606855600 28800 1 +0800}
{622580400 25200 0 +0700}
{638305200 28800 1 +0800}
{654634800 25200 0 +0700}
{670359600 21600 0 +0600}
{670363200 25200 1 +0700}
{686088000 21600 0 +0600}
{695764800 25200 0 +0700}
{701809200 28800 1 +0800}
{717534000 25200 0 +0700}
{733258800 28800 1 +0800}
{748983600 25200 0 +0700}
{764708400 28800 1 +0800}
{780433200 25200 0 +0700}
{796158000 28800 1 +0800}
{811882800 25200 0 +0700}
{828212400 28800 1 +0800}
{846356400 25200 0 +0700}
{859662000 28800 1 +0800}
{877806000 25200 0 +0700}
{891111600 28800 1 +0800}
{909255600 25200 0 +0700}
{922561200 28800 1 +0800}
{941310000 25200 0 +0700}
{954010800 28800 1 +0800}
{972759600 25200 0 +0700}
{985460400 28800 1 +0800}
{1004209200 25200 0 +0700}
{1017514800 28800 1 +0800}
{1020196800 25200 0 +0700}
{1035662400 21600 0 +0600}
{1048968000 25200 1 +0700}
{1067112000 21600 0 +0600}
{1080417600 25200 1 +0700}
{1099166400 21600 0 +0600}
{1111867200 25200 1 +0700}
{1130616000 21600 0 +0600}
{1143316800 25200 1 +0700}
{1162065600 21600 0 +0600}
{1174766400 25200 1 +0700}
{1193515200 21600 0 +0600}
{1206820800 25200 1 +0700}
{1224964800 21600 0 +0600}
{1238270400 25200 1 +0700}
{1256414400 21600 0 +0600}
{1269720000 25200 1 +0700}
{1288468800 21600 0 +0600}
{1301169600 25200 0 +0700}
{1414263600 21600 0 +0600}
{1464465600 25200 0 +0700}
}
|
Changes to library/tzdata/Asia/Ulaanbaatar.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ulaanbaatar) {
{-9223372036854775808 25652 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ulaanbaatar) {
{-9223372036854775808 25652 0 LMT}
{-2032931252 25200 0 +0700}
{252435600 28800 0 +0800}
{417974400 32400 1 +0900}
{433782000 28800 0 +0800}
{449596800 32400 1 +0900}
{465318000 28800 0 +0800}
{481046400 32400 1 +0900}
{496767600 28800 0 +0800}
{512496000 32400 1 +0900}
{528217200 28800 0 +0800}
{543945600 32400 1 +0900}
{559666800 28800 0 +0800}
{575395200 32400 1 +0900}
{591116400 28800 0 +0800}
{606844800 32400 1 +0900}
{622566000 28800 0 +0800}
{638294400 32400 1 +0900}
{654620400 28800 0 +0800}
{670348800 32400 1 +0900}
{686070000 28800 0 +0800}
{701798400 32400 1 +0900}
{717519600 28800 0 +0800}
{733248000 32400 1 +0900}
{748969200 28800 0 +0800}
{764697600 32400 1 +0900}
{780418800 28800 0 +0800}
{796147200 32400 1 +0900}
{811868400 28800 0 +0800}
{828201600 32400 1 +0900}
{843922800 28800 0 +0800}
{859651200 32400 1 +0900}
{875372400 28800 0 +0800}
{891100800 32400 1 +0900}
{906822000 28800 0 +0800}
{988394400 32400 1 +0900}
{1001696400 28800 0 +0800}
{1017424800 32400 1 +0900}
{1033146000 28800 0 +0800}
{1048874400 32400 1 +0900}
{1064595600 28800 0 +0800}
{1080324000 32400 1 +0900}
{1096045200 28800 0 +0800}
{1111773600 32400 1 +0900}
{1127494800 28800 0 +0800}
{1143223200 32400 1 +0900}
{1159549200 28800 0 +0800}
{1427479200 32400 1 +0900}
{1443193200 28800 0 +0800}
{1458928800 32400 1 +0900}
{1474642800 28800 0 +0800}
}
|
Changes to library/tzdata/Asia/Urumqi.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Urumqi) {
{-9223372036854775808 21020 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Urumqi) {
{-9223372036854775808 21020 0 LMT}
{-1325483420 21600 0 +0600}
}
|
Changes to library/tzdata/Asia/Ust-Nera.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ust-Nera) {
{-9223372036854775808 34374 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ust-Nera) {
{-9223372036854775808 34374 0 LMT}
{-1579426374 28800 0 +0800}
{354898800 43200 0 +1200}
{370699200 39600 0 +1100}
{386427600 43200 1 +1200}
{402235200 39600 0 +1100}
{417963600 43200 1 +1200}
{433771200 39600 0 +1100}
{449586000 43200 1 +1200}
{465318000 39600 0 +1100}
{481042800 43200 1 +1200}
{496767600 39600 0 +1100}
{512492400 43200 1 +1200}
{528217200 39600 0 +1100}
{543942000 43200 1 +1200}
{559666800 39600 0 +1100}
{575391600 43200 1 +1200}
{591116400 39600 0 +1100}
{606841200 43200 1 +1200}
{622566000 39600 0 +1100}
{638290800 43200 1 +1200}
{654620400 39600 0 +1100}
{670345200 36000 0 +1000}
{670348800 39600 1 +1100}
{686073600 36000 0 +1000}
{695750400 39600 0 +1100}
{701794800 43200 1 +1200}
{717519600 39600 0 +1100}
{733244400 43200 1 +1200}
{748969200 39600 0 +1100}
{764694000 43200 1 +1200}
{780418800 39600 0 +1100}
{796143600 43200 1 +1200}
{811868400 39600 0 +1100}
{828198000 43200 1 +1200}
{846342000 39600 0 +1100}
{859647600 43200 1 +1200}
{877791600 39600 0 +1100}
{891097200 43200 1 +1200}
{909241200 39600 0 +1100}
{922546800 43200 1 +1200}
{941295600 39600 0 +1100}
{953996400 43200 1 +1200}
{972745200 39600 0 +1100}
{985446000 43200 1 +1200}
{1004194800 39600 0 +1100}
{1017500400 43200 1 +1200}
{1035644400 39600 0 +1100}
{1048950000 43200 1 +1200}
{1067094000 39600 0 +1100}
{1080399600 43200 1 +1200}
{1099148400 39600 0 +1100}
{1111849200 43200 1 +1200}
{1130598000 39600 0 +1100}
{1143298800 43200 1 +1200}
{1162047600 39600 0 +1100}
{1174748400 43200 1 +1200}
{1193497200 39600 0 +1100}
{1206802800 43200 1 +1200}
{1224946800 39600 0 +1100}
{1238252400 43200 1 +1200}
{1256396400 39600 0 +1100}
{1269702000 43200 1 +1200}
{1288450800 39600 0 +1100}
{1301151600 43200 0 +1200}
{1315828800 39600 0 +1100}
{1414249200 36000 0 +1000}
}
|
Changes to library/tzdata/Asia/Vladivostok.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Vladivostok) {
{-9223372036854775808 31651 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Vladivostok) {
{-9223372036854775808 31651 0 LMT}
{-1487321251 32400 0 +0900}
{-1247562000 36000 0 +1000}
{354895200 39600 1 +1100}
{370702800 36000 0 +1000}
{386431200 39600 1 +1100}
{402238800 36000 0 +1000}
{417967200 39600 1 +1100}
{433774800 36000 0 +1000}
{449589600 39600 1 +1100}
{465321600 36000 0 +1000}
{481046400 39600 1 +1100}
{496771200 36000 0 +1000}
{512496000 39600 1 +1100}
{528220800 36000 0 +1000}
{543945600 39600 1 +1100}
{559670400 36000 0 +1000}
{575395200 39600 1 +1100}
{591120000 36000 0 +1000}
{606844800 39600 1 +1100}
{622569600 36000 0 +1000}
{638294400 39600 1 +1100}
{654624000 36000 0 +1000}
{670348800 32400 0 +0900}
{670352400 36000 1 +1000}
{686077200 32400 0 +0900}
{695754000 36000 0 +1000}
{701798400 39600 1 +1100}
{717523200 36000 0 +1000}
{733248000 39600 1 +1100}
{748972800 36000 0 +1000}
{764697600 39600 1 +1100}
{780422400 36000 0 +1000}
{796147200 39600 1 +1100}
{811872000 36000 0 +1000}
{828201600 39600 1 +1100}
{846345600 36000 0 +1000}
{859651200 39600 1 +1100}
{877795200 36000 0 +1000}
{891100800 39600 1 +1100}
{909244800 36000 0 +1000}
{922550400 39600 1 +1100}
{941299200 36000 0 +1000}
{954000000 39600 1 +1100}
{972748800 36000 0 +1000}
{985449600 39600 1 +1100}
{1004198400 36000 0 +1000}
{1017504000 39600 1 +1100}
{1035648000 36000 0 +1000}
{1048953600 39600 1 +1100}
{1067097600 36000 0 +1000}
{1080403200 39600 1 +1100}
{1099152000 36000 0 +1000}
{1111852800 39600 1 +1100}
{1130601600 36000 0 +1000}
{1143302400 39600 1 +1100}
{1162051200 36000 0 +1000}
{1174752000 39600 1 +1100}
{1193500800 36000 0 +1000}
{1206806400 39600 1 +1100}
{1224950400 36000 0 +1000}
{1238256000 39600 1 +1100}
{1256400000 36000 0 +1000}
{1269705600 39600 1 +1100}
{1288454400 36000 0 +1000}
{1301155200 39600 0 +1100}
{1414249200 36000 0 +1000}
}
|
Changes to library/tzdata/Asia/Yakutsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yakutsk) {
{-9223372036854775808 31138 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yakutsk) {
{-9223372036854775808 31138 0 LMT}
{-1579423138 28800 0 +0800}
{-1247558400 32400 0 +0900}
{354898800 36000 1 +1000}
{370706400 32400 0 +0900}
{386434800 36000 1 +1000}
{402242400 32400 0 +0900}
{417970800 36000 1 +1000}
{433778400 32400 0 +0900}
{449593200 36000 1 +1000}
{465325200 32400 0 +0900}
{481050000 36000 1 +1000}
{496774800 32400 0 +0900}
{512499600 36000 1 +1000}
{528224400 32400 0 +0900}
{543949200 36000 1 +1000}
{559674000 32400 0 +0900}
{575398800 36000 1 +1000}
{591123600 32400 0 +0900}
{606848400 36000 1 +1000}
{622573200 32400 0 +0900}
{638298000 36000 1 +1000}
{654627600 32400 0 +0900}
{670352400 28800 0 +0800}
{670356000 32400 1 +0900}
{686080800 28800 0 +0800}
{695757600 32400 0 +0900}
{701802000 36000 1 +1000}
{717526800 32400 0 +0900}
{733251600 36000 1 +1000}
{748976400 32400 0 +0900}
{764701200 36000 1 +1000}
{780426000 32400 0 +0900}
{796150800 36000 1 +1000}
{811875600 32400 0 +0900}
{828205200 36000 1 +1000}
{846349200 32400 0 +0900}
{859654800 36000 1 +1000}
{877798800 32400 0 +0900}
{891104400 36000 1 +1000}
{909248400 32400 0 +0900}
{922554000 36000 1 +1000}
{941302800 32400 0 +0900}
{954003600 36000 1 +1000}
{972752400 32400 0 +0900}
{985453200 36000 1 +1000}
{1004202000 32400 0 +0900}
{1017507600 36000 1 +1000}
{1035651600 32400 0 +0900}
{1048957200 36000 1 +1000}
{1067101200 32400 0 +0900}
{1080406800 36000 1 +1000}
{1099155600 32400 0 +0900}
{1111856400 36000 1 +1000}
{1130605200 32400 0 +0900}
{1143306000 36000 1 +1000}
{1162054800 32400 0 +0900}
{1174755600 36000 1 +1000}
{1193504400 32400 0 +0900}
{1206810000 36000 1 +1000}
{1224954000 32400 0 +0900}
{1238259600 36000 1 +1000}
{1256403600 32400 0 +0900}
{1269709200 36000 1 +1000}
{1288458000 32400 0 +0900}
{1301158800 36000 0 +1000}
{1414252800 32400 0 +0900}
}
|
Changes to library/tzdata/Asia/Yangon.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yangon) {
{-9223372036854775808 23087 0 LMT}
{-2840163887 23087 0 RMT}
{-1577946287 23400 0 +0630}
| | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yangon) {
{-9223372036854775808 23087 0 LMT}
{-2840163887 23087 0 RMT}
{-1577946287 23400 0 +0630}
{-873268200 32400 0 +0900}
{-778410000 23400 0 +0630}
}
|
Changes to library/tzdata/Asia/Yekaterinburg.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yekaterinburg) {
{-9223372036854775808 14553 0 LMT}
{-1688270553 13505 0 PMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yekaterinburg) {
{-9223372036854775808 14553 0 LMT}
{-1688270553 13505 0 PMT}
{-1592610305 14400 0 +0400}
{-1247544000 18000 0 +0500}
{354913200 21600 1 +0600}
{370720800 18000 0 +0500}
{386449200 21600 1 +0600}
{402256800 18000 0 +0500}
{417985200 21600 1 +0600}
{433792800 18000 0 +0500}
{449607600 21600 1 +0600}
{465339600 18000 0 +0500}
{481064400 21600 1 +0600}
{496789200 18000 0 +0500}
{512514000 21600 1 +0600}
{528238800 18000 0 +0500}
{543963600 21600 1 +0600}
{559688400 18000 0 +0500}
{575413200 21600 1 +0600}
{591138000 18000 0 +0500}
{606862800 21600 1 +0600}
{622587600 18000 0 +0500}
{638312400 21600 1 +0600}
{654642000 18000 0 +0500}
{670366800 14400 0 +0400}
{670370400 18000 1 +0500}
{686095200 14400 0 +0400}
{695772000 18000 0 +0500}
{701816400 21600 1 +0600}
{717541200 18000 0 +0500}
{733266000 21600 1 +0600}
{748990800 18000 0 +0500}
{764715600 21600 1 +0600}
{780440400 18000 0 +0500}
{796165200 21600 1 +0600}
{811890000 18000 0 +0500}
{828219600 21600 1 +0600}
{846363600 18000 0 +0500}
{859669200 21600 1 +0600}
{877813200 18000 0 +0500}
{891118800 21600 1 +0600}
{909262800 18000 0 +0500}
{922568400 21600 1 +0600}
{941317200 18000 0 +0500}
{954018000 21600 1 +0600}
{972766800 18000 0 +0500}
{985467600 21600 1 +0600}
{1004216400 18000 0 +0500}
{1017522000 21600 1 +0600}
{1035666000 18000 0 +0500}
{1048971600 21600 1 +0600}
{1067115600 18000 0 +0500}
{1080421200 21600 1 +0600}
{1099170000 18000 0 +0500}
{1111870800 21600 1 +0600}
{1130619600 18000 0 +0500}
{1143320400 21600 1 +0600}
{1162069200 18000 0 +0500}
{1174770000 21600 1 +0600}
{1193518800 18000 0 +0500}
{1206824400 21600 1 +0600}
{1224968400 18000 0 +0500}
{1238274000 21600 1 +0600}
{1256418000 18000 0 +0500}
{1269723600 21600 1 +0600}
{1288472400 18000 0 +0500}
{1301173200 21600 0 +0600}
{1414267200 18000 0 +0500}
}
|
Changes to library/tzdata/Asia/Yerevan.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yerevan) {
{-9223372036854775808 10680 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Yerevan) {
{-9223372036854775808 10680 0 LMT}
{-1441162680 10800 0 +0300}
{-405140400 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 18000 1 +0500}
{591141600 14400 0 +0400}
{606866400 18000 1 +0500}
{622591200 14400 0 +0400}
{638316000 18000 1 +0500}
{654645600 14400 0 +0400}
{670370400 10800 0 +0300}
{670374000 14400 1 +0400}
{686098800 10800 0 +0300}
{701823600 14400 1 +0400}
{717548400 10800 0 +0300}
{733273200 14400 1 +0400}
{748998000 10800 0 +0300}
{764722800 14400 1 +0400}
{780447600 10800 0 +0300}
{796172400 14400 1 +0400}
{811897200 14400 0 +0400}
{852062400 14400 0 +0400}
{859672800 18000 1 +0500}
{877816800 14400 0 +0400}
{891122400 18000 1 +0500}
{909266400 14400 0 +0400}
{922572000 18000 1 +0500}
{941320800 14400 0 +0400}
{954021600 18000 1 +0500}
{972770400 14400 0 +0400}
{985471200 18000 1 +0500}
{1004220000 14400 0 +0400}
{1017525600 18000 1 +0500}
{1035669600 14400 0 +0400}
{1048975200 18000 1 +0500}
{1067119200 14400 0 +0400}
{1080424800 18000 1 +0500}
{1099173600 14400 0 +0400}
{1111874400 18000 1 +0500}
{1130623200 14400 0 +0400}
{1143324000 18000 1 +0500}
{1162072800 14400 0 +0400}
{1174773600 18000 1 +0500}
{1193522400 14400 0 +0400}
{1206828000 18000 1 +0500}
{1224972000 14400 0 +0400}
{1238277600 18000 1 +0500}
{1256421600 14400 0 +0400}
{1269727200 18000 1 +0500}
{1288476000 14400 0 +0400}
{1293825600 14400 0 +0400}
{1301176800 18000 1 +0500}
{1319925600 14400 0 +0400}
}
|
Changes to library/tzdata/Atlantic/Azores.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Azores) {
{-9223372036854775808 -6160 0 LMT}
{-2713904240 -6872 0 HMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | > | | | > | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < < | | | | < | < < | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Azores) {
{-9223372036854775808 -6160 0 LMT}
{-2713904240 -6872 0 HMT}
{-1830376800 -7200 0 -0200}
{-1689548400 -3600 1 -0100}
{-1677794400 -7200 0 -0200}
{-1667426400 -3600 1 -0100}
{-1647730800 -7200 0 -0200}
{-1635890400 -3600 1 -0100}
{-1616194800 -7200 0 -0200}
{-1604354400 -3600 1 -0100}
{-1584658800 -7200 0 -0200}
{-1572732000 -3600 1 -0100}
{-1553036400 -7200 0 -0200}
{-1541196000 -3600 1 -0100}
{-1521500400 -7200 0 -0200}
{-1442444400 -3600 1 -0100}
{-1427670000 -7200 0 -0200}
{-1379286000 -3600 1 -0100}
{-1364770800 -7200 0 -0200}
{-1348441200 -3600 1 -0100}
{-1333321200 -7200 0 -0200}
{-1316386800 -3600 1 -0100}
{-1301266800 -7200 0 -0200}
{-1284332400 -3600 1 -0100}
{-1269817200 -7200 0 -0200}
{-1221433200 -3600 1 -0100}
{-1206918000 -7200 0 -0200}
{-1191193200 -3600 1 -0100}
{-1175468400 -7200 0 -0200}
{-1127689200 -3600 1 -0100}
{-1111964400 -7200 0 -0200}
{-1096844400 -3600 1 -0100}
{-1080514800 -7200 0 -0200}
{-1063580400 -3600 1 -0100}
{-1049065200 -7200 0 -0200}
{-1033340400 -3600 1 -0100}
{-1017615600 -7200 0 -0200}
{-1002495600 -3600 1 -0100}
{-986166000 -7200 0 -0200}
{-969231600 -3600 1 -0100}
{-950482800 -7200 0 -0200}
{-942015600 -3600 1 -0100}
{-922489200 -7200 0 -0200}
{-906937200 -3600 1 -0100}
{-891126000 -7200 0 -0200}
{-877302000 -3600 1 -0100}
{-873676800 0 1 +0000}
{-864000000 -3600 1 -0100}
{-857948400 -7200 0 -0200}
{-845852400 -3600 1 -0100}
{-842832000 0 1 +0000}
{-831340800 -3600 1 -0100}
{-825894000 -7200 0 -0200}
{-814402800 -3600 1 -0100}
{-810777600 0 1 +0000}
{-799891200 -3600 1 -0100}
{-794444400 -7200 0 -0200}
{-782953200 -3600 1 -0100}
{-779328000 0 1 +0000}
{-768441600 -3600 1 -0100}
{-762994800 -7200 0 -0200}
{-749084400 -3600 1 -0100}
{-733359600 -7200 0 -0200}
{-717624000 -3600 1 -0100}
{-701899200 -7200 0 -0200}
{-686174400 -3600 1 -0100}
{-670449600 -7200 0 -0200}
{-654724800 -3600 1 -0100}
{-639000000 -7200 0 -0200}
{-623275200 -3600 1 -0100}
{-607550400 -7200 0 -0200}
{-591825600 -3600 1 -0100}
{-575496000 -7200 0 -0200}
{-559771200 -3600 1 -0100}
{-544046400 -7200 0 -0200}
{-528321600 -3600 1 -0100}
{-512596800 -7200 0 -0200}
{-496872000 -3600 1 -0100}
{-481147200 -7200 0 -0200}
{-465422400 -3600 1 -0100}
{-449697600 -7200 0 -0200}
{-433972800 -3600 1 -0100}
{-417643200 -7200 0 -0200}
{-401918400 -3600 1 -0100}
{-386193600 -7200 0 -0200}
{-370468800 -3600 1 -0100}
{-354744000 -7200 0 -0200}
{-339019200 -3600 1 -0100}
{-323294400 -7200 0 -0200}
{-307569600 -3600 1 -0100}
{-291844800 -7200 0 -0200}
{-276120000 -3600 1 -0100}
{-260395200 -7200 0 -0200}
{-244670400 -3600 1 -0100}
{-228340800 -7200 0 -0200}
{-212616000 -3600 1 -0100}
{-196891200 -7200 0 -0200}
{-181166400 -3600 1 -0100}
{-165441600 -7200 0 -0200}
{-149716800 -3600 1 -0100}
{-133992000 -7200 0 -0200}
{-118267200 -3600 1 -0100}
{-102542400 -3600 0 -0100}
{386125200 0 0 +0000}
{401850000 -3600 0 -0100}
{417574800 0 1 +0000}
{433299600 -3600 0 -0100}
{449024400 0 1 +0000}
{465354000 -3600 0 -0100}
{481078800 0 1 +0000}
{496803600 -3600 0 -0100}
{504925200 -3600 0 -0100}
{512528400 0 1 +0000}
{528253200 -3600 0 -0100}
{543978000 0 1 +0000}
{559702800 -3600 0 -0100}
{575427600 0 1 +0000}
{591152400 -3600 0 -0100}
{606877200 0 1 +0000}
{622602000 -3600 0 -0100}
{638326800 0 1 +0000}
{654656400 -3600 0 -0100}
{670381200 0 1 +0000}
{686106000 -3600 0 -0100}
{701830800 0 1 +0000}
{717555600 -3600 0 -0100}
{725421600 0 0 WET}
{733280400 3600 1 WEST}
{740278800 0 0 +0000}
{749005200 -3600 0 -0100}
{764730000 0 1 +0000}
{780454800 -3600 0 -0100}
{796179600 0 1 +0000}
{811904400 -3600 0 -0100}
{828234000 0 1 +0000}
{846378000 -3600 0 -0100}
{859683600 0 1 +0000}
{877827600 -3600 0 -0100}
{891133200 0 1 +0000}
{909277200 -3600 0 -0100}
{922582800 0 1 +0000}
{941331600 -3600 0 -0100}
{954032400 0 1 +0000}
{972781200 -3600 0 -0100}
{985482000 0 1 +0000}
{1004230800 -3600 0 -0100}
{1017536400 0 1 +0000}
{1035680400 -3600 0 -0100}
{1048986000 0 1 +0000}
{1067130000 -3600 0 -0100}
{1080435600 0 1 +0000}
{1099184400 -3600 0 -0100}
{1111885200 0 1 +0000}
{1130634000 -3600 0 -0100}
{1143334800 0 1 +0000}
{1162083600 -3600 0 -0100}
{1174784400 0 1 +0000}
{1193533200 -3600 0 -0100}
{1206838800 0 1 +0000}
{1224982800 -3600 0 -0100}
{1238288400 0 1 +0000}
{1256432400 -3600 0 -0100}
{1269738000 0 1 +0000}
{1288486800 -3600 0 -0100}
{1301187600 0 1 +0000}
{1319936400 -3600 0 -0100}
{1332637200 0 1 +0000}
{1351386000 -3600 0 -0100}
{1364691600 0 1 +0000}
{1382835600 -3600 0 -0100}
{1396141200 0 1 +0000}
{1414285200 -3600 0 -0100}
{1427590800 0 1 +0000}
{1445734800 -3600 0 -0100}
{1459040400 0 1 +0000}
{1477789200 -3600 0 -0100}
{1490490000 0 1 +0000}
{1509238800 -3600 0 -0100}
{1521939600 0 1 +0000}
{1540688400 -3600 0 -0100}
{1553994000 0 1 +0000}
{1572138000 -3600 0 -0100}
{1585443600 0 1 +0000}
{1603587600 -3600 0 -0100}
{1616893200 0 1 +0000}
{1635642000 -3600 0 -0100}
{1648342800 0 1 +0000}
{1667091600 -3600 0 -0100}
{1679792400 0 1 +0000}
{1698541200 -3600 0 -0100}
{1711846800 0 1 +0000}
{1729990800 -3600 0 -0100}
{1743296400 0 1 +0000}
{1761440400 -3600 0 -0100}
{1774746000 0 1 +0000}
{1792890000 -3600 0 -0100}
{1806195600 0 1 +0000}
{1824944400 -3600 0 -0100}
{1837645200 0 1 +0000}
{1856394000 -3600 0 -0100}
{1869094800 0 1 +0000}
{1887843600 -3600 0 -0100}
{1901149200 0 1 +0000}
{1919293200 -3600 0 -0100}
{1932598800 0 1 +0000}
{1950742800 -3600 0 -0100}
{1964048400 0 1 +0000}
{1982797200 -3600 0 -0100}
{1995498000 0 1 +0000}
{2014246800 -3600 0 -0100}
{2026947600 0 1 +0000}
{2045696400 -3600 0 -0100}
{2058397200 0 1 +0000}
{2077146000 -3600 0 -0100}
{2090451600 0 1 +0000}
{2108595600 -3600 0 -0100}
{2121901200 0 1 +0000}
{2140045200 -3600 0 -0100}
{2153350800 0 1 +0000}
{2172099600 -3600 0 -0100}
{2184800400 0 1 +0000}
{2203549200 -3600 0 -0100}
{2216250000 0 1 +0000}
{2234998800 -3600 0 -0100}
{2248304400 0 1 +0000}
{2266448400 -3600 0 -0100}
{2279754000 0 1 +0000}
{2297898000 -3600 0 -0100}
{2311203600 0 1 +0000}
{2329347600 -3600 0 -0100}
{2342653200 0 1 +0000}
{2361402000 -3600 0 -0100}
{2374102800 0 1 +0000}
{2392851600 -3600 0 -0100}
{2405552400 0 1 +0000}
{2424301200 -3600 0 -0100}
{2437606800 0 1 +0000}
{2455750800 -3600 0 -0100}
{2469056400 0 1 +0000}
{2487200400 -3600 0 -0100}
{2500506000 0 1 +0000}
{2519254800 -3600 0 -0100}
{2531955600 0 1 +0000}
{2550704400 -3600 0 -0100}
{2563405200 0 1 +0000}
{2582154000 -3600 0 -0100}
{2595459600 0 1 +0000}
{2613603600 -3600 0 -0100}
{2626909200 0 1 +0000}
{2645053200 -3600 0 -0100}
{2658358800 0 1 +0000}
{2676502800 -3600 0 -0100}
{2689808400 0 1 +0000}
{2708557200 -3600 0 -0100}
{2721258000 0 1 +0000}
{2740006800 -3600 0 -0100}
{2752707600 0 1 +0000}
{2771456400 -3600 0 -0100}
{2784762000 0 1 +0000}
{2802906000 -3600 0 -0100}
{2816211600 0 1 +0000}
{2834355600 -3600 0 -0100}
{2847661200 0 1 +0000}
{2866410000 -3600 0 -0100}
{2879110800 0 1 +0000}
{2897859600 -3600 0 -0100}
{2910560400 0 1 +0000}
{2929309200 -3600 0 -0100}
{2942010000 0 1 +0000}
{2960758800 -3600 0 -0100}
{2974064400 0 1 +0000}
{2992208400 -3600 0 -0100}
{3005514000 0 1 +0000}
{3023658000 -3600 0 -0100}
{3036963600 0 1 +0000}
{3055712400 -3600 0 -0100}
{3068413200 0 1 +0000}
{3087162000 -3600 0 -0100}
{3099862800 0 1 +0000}
{3118611600 -3600 0 -0100}
{3131917200 0 1 +0000}
{3150061200 -3600 0 -0100}
{3163366800 0 1 +0000}
{3181510800 -3600 0 -0100}
{3194816400 0 1 +0000}
{3212960400 -3600 0 -0100}
{3226266000 0 1 +0000}
{3245014800 -3600 0 -0100}
{3257715600 0 1 +0000}
{3276464400 -3600 0 -0100}
{3289165200 0 1 +0000}
{3307914000 -3600 0 -0100}
{3321219600 0 1 +0000}
{3339363600 -3600 0 -0100}
{3352669200 0 1 +0000}
{3370813200 -3600 0 -0100}
{3384118800 0 1 +0000}
{3402867600 -3600 0 -0100}
{3415568400 0 1 +0000}
{3434317200 -3600 0 -0100}
{3447018000 0 1 +0000}
{3465766800 -3600 0 -0100}
{3479072400 0 1 +0000}
{3497216400 -3600 0 -0100}
{3510522000 0 1 +0000}
{3528666000 -3600 0 -0100}
{3541971600 0 1 +0000}
{3560115600 -3600 0 -0100}
{3573421200 0 1 +0000}
{3592170000 -3600 0 -0100}
{3604870800 0 1 +0000}
{3623619600 -3600 0 -0100}
{3636320400 0 1 +0000}
{3655069200 -3600 0 -0100}
{3668374800 0 1 +0000}
{3686518800 -3600 0 -0100}
{3699824400 0 1 +0000}
{3717968400 -3600 0 -0100}
{3731274000 0 1 +0000}
{3750022800 -3600 0 -0100}
{3762723600 0 1 +0000}
{3781472400 -3600 0 -0100}
{3794173200 0 1 +0000}
{3812922000 -3600 0 -0100}
{3825622800 0 1 +0000}
{3844371600 -3600 0 -0100}
{3857677200 0 1 +0000}
{3875821200 -3600 0 -0100}
{3889126800 0 1 +0000}
{3907270800 -3600 0 -0100}
{3920576400 0 1 +0000}
{3939325200 -3600 0 -0100}
{3952026000 0 1 +0000}
{3970774800 -3600 0 -0100}
{3983475600 0 1 +0000}
{4002224400 -3600 0 -0100}
{4015530000 0 1 +0000}
{4033674000 -3600 0 -0100}
{4046979600 0 1 +0000}
{4065123600 -3600 0 -0100}
{4078429200 0 1 +0000}
{4096573200 -3600 0 -0100}
}
|
Changes to library/tzdata/Atlantic/Canary.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Canary) {
{-9223372036854775808 -3696 0 LMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Canary) {
{-9223372036854775808 -3696 0 LMT}
{-1509663504 -3600 0 -0100}
{-733874400 0 0 WET}
{323827200 3600 1 WEST}
{338950800 0 0 WET}
{354675600 3600 1 WEST}
{370400400 0 0 WET}
{386125200 3600 1 WEST}
{401850000 0 0 WET}
|
| ︙ | ︙ |
Changes to library/tzdata/Atlantic/Cape_Verde.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Cape_Verde) {
{-9223372036854775808 -5644 0 LMT}
| | | | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Cape_Verde) {
{-9223372036854775808 -5644 0 LMT}
{-1830376800 -7200 0 -0200}
{-862610400 -3600 1 -0100}
{-764118000 -7200 0 -0200}
{186120000 -3600 0 -0100}
}
|
Changes to library/tzdata/Atlantic/Madeira.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Madeira) {
{-9223372036854775808 -4056 0 LMT}
{-2713906344 -4056 0 FMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | > | | | > | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | < < | | | < < < < | < | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Madeira) {
{-9223372036854775808 -4056 0 LMT}
{-2713906344 -4056 0 FMT}
{-1830380400 -3600 0 -0100}
{-1689552000 0 1 +0000}
{-1677798000 -3600 0 -0100}
{-1667430000 0 1 +0000}
{-1647734400 -3600 0 -0100}
{-1635894000 0 1 +0000}
{-1616198400 -3600 0 -0100}
{-1604358000 0 1 +0000}
{-1584662400 -3600 0 -0100}
{-1572735600 0 1 +0000}
{-1553040000 -3600 0 -0100}
{-1541199600 0 1 +0000}
{-1521504000 -3600 0 -0100}
{-1442448000 0 1 +0000}
{-1427673600 -3600 0 -0100}
{-1379289600 0 1 +0000}
{-1364774400 -3600 0 -0100}
{-1348444800 0 1 +0000}
{-1333324800 -3600 0 -0100}
{-1316390400 0 1 +0000}
{-1301270400 -3600 0 -0100}
{-1284336000 0 1 +0000}
{-1269820800 -3600 0 -0100}
{-1221436800 0 1 +0000}
{-1206921600 -3600 0 -0100}
{-1191196800 0 1 +0000}
{-1175472000 -3600 0 -0100}
{-1127692800 0 1 +0000}
{-1111968000 -3600 0 -0100}
{-1096848000 0 1 +0000}
{-1080518400 -3600 0 -0100}
{-1063584000 0 1 +0000}
{-1049068800 -3600 0 -0100}
{-1033344000 0 1 +0000}
{-1017619200 -3600 0 -0100}
{-1002499200 0 1 +0000}
{-986169600 -3600 0 -0100}
{-969235200 0 1 +0000}
{-950486400 -3600 0 -0100}
{-942019200 0 1 +0000}
{-922492800 -3600 0 -0100}
{-906940800 0 1 +0000}
{-891129600 -3600 0 -0100}
{-877305600 0 1 +0000}
{-873680400 3600 1 +0100}
{-864003600 0 1 +0000}
{-857952000 -3600 0 -0100}
{-845856000 0 1 +0000}
{-842835600 3600 1 +0100}
{-831344400 0 1 +0000}
{-825897600 -3600 0 -0100}
{-814406400 0 1 +0000}
{-810781200 3600 1 +0100}
{-799894800 0 1 +0000}
{-794448000 -3600 0 -0100}
{-782956800 0 1 +0000}
{-779331600 3600 1 +0100}
{-768445200 0 1 +0000}
{-762998400 -3600 0 -0100}
{-749088000 0 1 +0000}
{-733363200 -3600 0 -0100}
{-717627600 0 1 +0000}
{-701902800 -3600 0 -0100}
{-686178000 0 1 +0000}
{-670453200 -3600 0 -0100}
{-654728400 0 1 +0000}
{-639003600 -3600 0 -0100}
{-623278800 0 1 +0000}
{-607554000 -3600 0 -0100}
{-591829200 0 1 +0000}
{-575499600 -3600 0 -0100}
{-559774800 0 1 +0000}
{-544050000 -3600 0 -0100}
{-528325200 0 1 +0000}
{-512600400 -3600 0 -0100}
{-496875600 0 1 +0000}
{-481150800 -3600 0 -0100}
{-465426000 0 1 +0000}
{-449701200 -3600 0 -0100}
{-433976400 0 1 +0000}
{-417646800 -3600 0 -0100}
{-401922000 0 1 +0000}
{-386197200 -3600 0 -0100}
{-370472400 0 1 +0000}
{-354747600 -3600 0 -0100}
{-339022800 0 1 +0000}
{-323298000 -3600 0 -0100}
{-307573200 0 1 +0000}
{-291848400 -3600 0 -0100}
{-276123600 0 1 +0000}
{-260398800 -3600 0 -0100}
{-244674000 0 1 +0000}
{-228344400 -3600 0 -0100}
{-212619600 0 1 +0000}
{-196894800 -3600 0 -0100}
{-181170000 0 1 +0000}
{-165445200 -3600 0 -0100}
{-149720400 0 1 +0000}
{-133995600 -3600 0 -0100}
{-118270800 0 1 +0000}
{-102546000 0 0 WET}
{386726400 3600 0 WEST}
{401846400 0 0 WET}
{417571200 3600 1 WEST}
{433296000 0 0 WET}
{449020800 3600 1 WEST}
{465350400 0 0 WET}
{481075200 3600 1 WEST}
{496800000 0 0 WET}
{512524800 3600 1 WEST}
{523148400 3600 0 WEST}
{528253200 0 0 WET}
{543978000 3600 1 WEST}
{559702800 0 0 WET}
{575427600 3600 1 WEST}
{591152400 0 0 WET}
{606877200 3600 1 WEST}
{622602000 0 0 WET}
|
| ︙ | ︙ |
Changes to library/tzdata/Atlantic/South_Georgia.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/South_Georgia) {
{-9223372036854775808 -8768 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/South_Georgia) {
{-9223372036854775808 -8768 0 LMT}
{-2524512832 -7200 0 -0200}
}
|
Changes to library/tzdata/Atlantic/Stanley.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Stanley) {
{-9223372036854775808 -13884 0 LMT}
{-2524507716 -13884 0 SMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Stanley) {
{-9223372036854775808 -13884 0 LMT}
{-2524507716 -13884 0 SMT}
{-1824235716 -14400 0 -0400}
{-1018209600 -10800 1 -0300}
{-1003093200 -14400 0 -0400}
{-986760000 -10800 1 -0300}
{-971643600 -14400 0 -0400}
{-954705600 -10800 1 -0300}
{-939589200 -14400 0 -0400}
{-923256000 -10800 1 -0300}
{-908139600 -14400 0 -0400}
{-891806400 -10800 1 -0300}
{-876690000 -14400 0 -0400}
{-860356800 -10800 1 -0300}
{420606000 -7200 0 -0200}
{433303200 -7200 1 -0200}
{452052000 -10800 0 -0300}
{464151600 -7200 1 -0200}
{483501600 -10800 0 -0300}
{495597600 -14400 0 -0400}
{495604800 -10800 1 -0300}
{514350000 -14400 0 -0400}
{527054400 -10800 1 -0300}
{545799600 -14400 0 -0400}
{558504000 -10800 1 -0300}
{577249200 -14400 0 -0400}
{589953600 -10800 1 -0300}
{608698800 -14400 0 -0400}
{621403200 -10800 1 -0300}
{640753200 -14400 0 -0400}
{652852800 -10800 1 -0300}
{672202800 -14400 0 -0400}
{684907200 -10800 1 -0300}
{703652400 -14400 0 -0400}
{716356800 -10800 1 -0300}
{735102000 -14400 0 -0400}
{747806400 -10800 1 -0300}
{766551600 -14400 0 -0400}
{779256000 -10800 1 -0300}
{798001200 -14400 0 -0400}
{810705600 -10800 1 -0300}
{830055600 -14400 0 -0400}
{842760000 -10800 1 -0300}
{861505200 -14400 0 -0400}
{874209600 -10800 1 -0300}
{892954800 -14400 0 -0400}
{905659200 -10800 1 -0300}
{924404400 -14400 0 -0400}
{937108800 -10800 1 -0300}
{955854000 -14400 0 -0400}
{968558400 -10800 1 -0300}
{987310800 -14400 0 -0400}
{999410400 -10800 1 -0300}
{1019365200 -14400 0 -0400}
{1030860000 -10800 1 -0300}
{1050814800 -14400 0 -0400}
{1062914400 -10800 1 -0300}
{1082264400 -14400 0 -0400}
{1094364000 -10800 1 -0300}
{1113714000 -14400 0 -0400}
{1125813600 -10800 1 -0300}
{1145163600 -14400 0 -0400}
{1157263200 -10800 1 -0300}
{1176613200 -14400 0 -0400}
{1188712800 -10800 1 -0300}
{1208667600 -14400 0 -0400}
{1220767200 -10800 1 -0300}
{1240117200 -14400 0 -0400}
{1252216800 -10800 1 -0300}
{1271566800 -14400 0 -0400}
{1283662800 -10800 0 -0300}
}
|
Changes to library/tzdata/Australia/Eucla.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Eucla) {
{-9223372036854775808 30928 0 LMT}
| | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Eucla) {
{-9223372036854775808 30928 0 LMT}
{-2337928528 31500 0 +0845}
{-1672555500 35100 1 +0945}
{-1665384300 31500 0 +0845}
{-883637100 35100 1 +0945}
{-876120300 31500 0 +0845}
{-860395500 35100 1 +0945}
{-844670700 31500 0 +0845}
{-836473500 35100 0 +0945}
{152039700 35100 1 +0945}
{162926100 31500 0 +0845}
{436295700 35100 1 +0945}
{447182100 31500 0 +0845}
{690311700 35100 1 +0945}
{699383700 31500 0 +0845}
{1165079700 35100 1 +0945}
{1174756500 31500 0 +0845}
{1193505300 35100 1 +0945}
{1206810900 31500 0 +0845}
{1224954900 35100 1 +0945}
{1238260500 31500 0 +0845}
}
|
Changes to library/tzdata/Australia/Lord_Howe.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Lord_Howe) {
{-9223372036854775808 38180 0 LMT}
{-2364114980 36000 0 AEST}
{352216800 37800 0 +1030}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Lord_Howe) {
{-9223372036854775808 38180 0 LMT}
{-2364114980 36000 0 AEST}
{352216800 37800 0 +1030}
{372785400 41400 1 +1130}
{384273000 37800 0 +1030}
{404839800 41400 1 +1130}
{415722600 37800 0 +1030}
{436289400 41400 1 +1130}
{447172200 37800 0 +1030}
{467739000 41400 1 +1130}
{478621800 37800 0 +1030}
{488984400 37800 0 +1030}
{499188600 39600 1 +1100}
{511282800 37800 0 +1030}
{530033400 39600 1 +1100}
{542732400 37800 0 +1030}
{562087800 39600 1 +1100}
{574786800 37800 0 +1030}
{594142200 39600 1 +1100}
{606236400 37800 0 +1030}
{625591800 39600 1 +1100}
{636476400 37800 0 +1030}
{657041400 39600 1 +1100}
{667926000 37800 0 +1030}
{688491000 39600 1 +1100}
{699375600 37800 0 +1030}
{719940600 39600 1 +1100}
{731430000 37800 0 +1030}
{751995000 39600 1 +1100}
{762879600 37800 0 +1030}
{783444600 39600 1 +1100}
{794329200 37800 0 +1030}
{814894200 39600 1 +1100}
{828198000 37800 0 +1030}
{846343800 39600 1 +1100}
{859647600 37800 0 +1030}
{877793400 39600 1 +1100}
{891097200 37800 0 +1030}
{909243000 39600 1 +1100}
{922546800 37800 0 +1030}
{941297400 39600 1 +1100}
{953996400 37800 0 +1030}
{967303800 39600 1 +1100}
{985446000 37800 0 +1030}
{1004196600 39600 1 +1100}
{1017500400 37800 0 +1030}
{1035646200 39600 1 +1100}
{1048950000 37800 0 +1030}
{1067095800 39600 1 +1100}
{1080399600 37800 0 +1030}
{1099150200 39600 1 +1100}
{1111849200 37800 0 +1030}
{1130599800 39600 1 +1100}
{1143903600 37800 0 +1030}
{1162049400 39600 1 +1100}
{1174748400 37800 0 +1030}
{1193499000 39600 1 +1100}
{1207407600 37800 0 +1030}
{1223134200 39600 1 +1100}
{1238857200 37800 0 +1030}
{1254583800 39600 1 +1100}
{1270306800 37800 0 +1030}
{1286033400 39600 1 +1100}
{1301756400 37800 0 +1030}
{1317483000 39600 1 +1100}
{1333206000 37800 0 +1030}
{1349537400 39600 1 +1100}
{1365260400 37800 0 +1030}
{1380987000 39600 1 +1100}
{1396710000 37800 0 +1030}
{1412436600 39600 1 +1100}
{1428159600 37800 0 +1030}
{1443886200 39600 1 +1100}
{1459609200 37800 0 +1030}
{1475335800 39600 1 +1100}
{1491058800 37800 0 +1030}
{1506785400 39600 1 +1100}
{1522508400 37800 0 +1030}
{1538839800 39600 1 +1100}
{1554562800 37800 0 +1030}
{1570289400 39600 1 +1100}
{1586012400 37800 0 +1030}
{1601739000 39600 1 +1100}
{1617462000 37800 0 +1030}
{1633188600 39600 1 +1100}
{1648911600 37800 0 +1030}
{1664638200 39600 1 +1100}
{1680361200 37800 0 +1030}
{1696087800 39600 1 +1100}
{1712415600 37800 0 +1030}
{1728142200 39600 1 +1100}
{1743865200 37800 0 +1030}
{1759591800 39600 1 +1100}
{1775314800 37800 0 +1030}
{1791041400 39600 1 +1100}
{1806764400 37800 0 +1030}
{1822491000 39600 1 +1100}
{1838214000 37800 0 +1030}
{1853940600 39600 1 +1100}
{1869663600 37800 0 +1030}
{1885995000 39600 1 +1100}
{1901718000 37800 0 +1030}
{1917444600 39600 1 +1100}
{1933167600 37800 0 +1030}
{1948894200 39600 1 +1100}
{1964617200 37800 0 +1030}
{1980343800 39600 1 +1100}
{1996066800 37800 0 +1030}
{2011793400 39600 1 +1100}
{2027516400 37800 0 +1030}
{2043243000 39600 1 +1100}
{2058966000 37800 0 +1030}
{2075297400 39600 1 +1100}
{2091020400 37800 0 +1030}
{2106747000 39600 1 +1100}
{2122470000 37800 0 +1030}
{2138196600 39600 1 +1100}
{2153919600 37800 0 +1030}
{2169646200 39600 1 +1100}
{2185369200 37800 0 +1030}
{2201095800 39600 1 +1100}
{2216818800 37800 0 +1030}
{2233150200 39600 1 +1100}
{2248873200 37800 0 +1030}
{2264599800 39600 1 +1100}
{2280322800 37800 0 +1030}
{2296049400 39600 1 +1100}
{2311772400 37800 0 +1030}
{2327499000 39600 1 +1100}
{2343222000 37800 0 +1030}
{2358948600 39600 1 +1100}
{2374671600 37800 0 +1030}
{2390398200 39600 1 +1100}
{2406121200 37800 0 +1030}
{2422452600 39600 1 +1100}
{2438175600 37800 0 +1030}
{2453902200 39600 1 +1100}
{2469625200 37800 0 +1030}
{2485351800 39600 1 +1100}
{2501074800 37800 0 +1030}
{2516801400 39600 1 +1100}
{2532524400 37800 0 +1030}
{2548251000 39600 1 +1100}
{2563974000 37800 0 +1030}
{2579700600 39600 1 +1100}
{2596028400 37800 0 +1030}
{2611755000 39600 1 +1100}
{2627478000 37800 0 +1030}
{2643204600 39600 1 +1100}
{2658927600 37800 0 +1030}
{2674654200 39600 1 +1100}
{2690377200 37800 0 +1030}
{2706103800 39600 1 +1100}
{2721826800 37800 0 +1030}
{2737553400 39600 1 +1100}
{2753276400 37800 0 +1030}
{2769607800 39600 1 +1100}
{2785330800 37800 0 +1030}
{2801057400 39600 1 +1100}
{2816780400 37800 0 +1030}
{2832507000 39600 1 +1100}
{2848230000 37800 0 +1030}
{2863956600 39600 1 +1100}
{2879679600 37800 0 +1030}
{2895406200 39600 1 +1100}
{2911129200 37800 0 +1030}
{2926855800 39600 1 +1100}
{2942578800 37800 0 +1030}
{2958910200 39600 1 +1100}
{2974633200 37800 0 +1030}
{2990359800 39600 1 +1100}
{3006082800 37800 0 +1030}
{3021809400 39600 1 +1100}
{3037532400 37800 0 +1030}
{3053259000 39600 1 +1100}
{3068982000 37800 0 +1030}
{3084708600 39600 1 +1100}
{3100431600 37800 0 +1030}
{3116763000 39600 1 +1100}
{3132486000 37800 0 +1030}
{3148212600 39600 1 +1100}
{3163935600 37800 0 +1030}
{3179662200 39600 1 +1100}
{3195385200 37800 0 +1030}
{3211111800 39600 1 +1100}
{3226834800 37800 0 +1030}
{3242561400 39600 1 +1100}
{3258284400 37800 0 +1030}
{3274011000 39600 1 +1100}
{3289734000 37800 0 +1030}
{3306065400 39600 1 +1100}
{3321788400 37800 0 +1030}
{3337515000 39600 1 +1100}
{3353238000 37800 0 +1030}
{3368964600 39600 1 +1100}
{3384687600 37800 0 +1030}
{3400414200 39600 1 +1100}
{3416137200 37800 0 +1030}
{3431863800 39600 1 +1100}
{3447586800 37800 0 +1030}
{3463313400 39600 1 +1100}
{3479641200 37800 0 +1030}
{3495367800 39600 1 +1100}
{3511090800 37800 0 +1030}
{3526817400 39600 1 +1100}
{3542540400 37800 0 +1030}
{3558267000 39600 1 +1100}
{3573990000 37800 0 +1030}
{3589716600 39600 1 +1100}
{3605439600 37800 0 +1030}
{3621166200 39600 1 +1100}
{3636889200 37800 0 +1030}
{3653220600 39600 1 +1100}
{3668943600 37800 0 +1030}
{3684670200 39600 1 +1100}
{3700393200 37800 0 +1030}
{3716119800 39600 1 +1100}
{3731842800 37800 0 +1030}
{3747569400 39600 1 +1100}
{3763292400 37800 0 +1030}
{3779019000 39600 1 +1100}
{3794742000 37800 0 +1030}
{3810468600 39600 1 +1100}
{3826191600 37800 0 +1030}
{3842523000 39600 1 +1100}
{3858246000 37800 0 +1030}
{3873972600 39600 1 +1100}
{3889695600 37800 0 +1030}
{3905422200 39600 1 +1100}
{3921145200 37800 0 +1030}
{3936871800 39600 1 +1100}
{3952594800 37800 0 +1030}
{3968321400 39600 1 +1100}
{3984044400 37800 0 +1030}
{4000375800 39600 1 +1100}
{4016098800 37800 0 +1030}
{4031825400 39600 1 +1100}
{4047548400 37800 0 +1030}
{4063275000 39600 1 +1100}
{4078998000 37800 0 +1030}
{4094724600 39600 1 +1100}
}
|
Changes to library/tzdata/CET.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Brussels)]} {
LoadTimeZoneFile Europe/Brussels
}
set TZData(:CET) $TZData(:Europe/Brussels)
|
Changes to library/tzdata/CST6CDT.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Chicago)]} {
LoadTimeZoneFile America/Chicago
}
set TZData(:CST6CDT) $TZData(:America/Chicago)
|
Changes to library/tzdata/EET.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Athens)]} {
LoadTimeZoneFile Europe/Athens
}
set TZData(:EET) $TZData(:Europe/Athens)
|
Changes to library/tzdata/EST.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Panama)]} {
LoadTimeZoneFile America/Panama
}
set TZData(:EST) $TZData(:America/Panama)
|
Changes to library/tzdata/EST5EDT.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/New_York)]} {
LoadTimeZoneFile America/New_York
}
set TZData(:EST5EDT) $TZData(:America/New_York)
|
Changes to library/tzdata/Etc/GMT+1.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+1) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+1) {
{-9223372036854775808 -3600 0 -0100}
}
|
Changes to library/tzdata/Etc/GMT+10.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+10) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+10) {
{-9223372036854775808 -36000 0 -1000}
}
|
Changes to library/tzdata/Etc/GMT+11.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+11) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+11) {
{-9223372036854775808 -39600 0 -1100}
}
|
Changes to library/tzdata/Etc/GMT+12.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+12) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+12) {
{-9223372036854775808 -43200 0 -1200}
}
|
Changes to library/tzdata/Etc/GMT+2.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+2) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+2) {
{-9223372036854775808 -7200 0 -0200}
}
|
Changes to library/tzdata/Etc/GMT+3.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+3) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+3) {
{-9223372036854775808 -10800 0 -0300}
}
|
Changes to library/tzdata/Etc/GMT+4.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+4) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+4) {
{-9223372036854775808 -14400 0 -0400}
}
|
Changes to library/tzdata/Etc/GMT+5.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+5) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+5) {
{-9223372036854775808 -18000 0 -0500}
}
|
Changes to library/tzdata/Etc/GMT+6.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+6) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+6) {
{-9223372036854775808 -21600 0 -0600}
}
|
Changes to library/tzdata/Etc/GMT+7.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+7) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+7) {
{-9223372036854775808 -25200 0 -0700}
}
|
Changes to library/tzdata/Etc/GMT+8.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+8) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+8) {
{-9223372036854775808 -28800 0 -0800}
}
|
Changes to library/tzdata/Etc/GMT+9.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+9) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT+9) {
{-9223372036854775808 -32400 0 -0900}
}
|
Changes to library/tzdata/Etc/GMT-1.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-1) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-1) {
{-9223372036854775808 3600 0 +0100}
}
|
Changes to library/tzdata/Etc/GMT-10.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-10) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-10) {
{-9223372036854775808 36000 0 +1000}
}
|
Changes to library/tzdata/Etc/GMT-11.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-11) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-11) {
{-9223372036854775808 39600 0 +1100}
}
|
Changes to library/tzdata/Etc/GMT-12.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-12) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-12) {
{-9223372036854775808 43200 0 +1200}
}
|
Changes to library/tzdata/Etc/GMT-13.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-13) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-13) {
{-9223372036854775808 46800 0 +1300}
}
|
Changes to library/tzdata/Etc/GMT-14.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-14) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-14) {
{-9223372036854775808 50400 0 +1400}
}
|
Changes to library/tzdata/Etc/GMT-2.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-2) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-2) {
{-9223372036854775808 7200 0 +0200}
}
|
Changes to library/tzdata/Etc/GMT-3.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-3) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-3) {
{-9223372036854775808 10800 0 +0300}
}
|
Changes to library/tzdata/Etc/GMT-4.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-4) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-4) {
{-9223372036854775808 14400 0 +0400}
}
|
Changes to library/tzdata/Etc/GMT-5.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-5) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-5) {
{-9223372036854775808 18000 0 +0500}
}
|
Changes to library/tzdata/Etc/GMT-6.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-6) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-6) {
{-9223372036854775808 21600 0 +0600}
}
|
Changes to library/tzdata/Etc/GMT-7.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-7) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-7) {
{-9223372036854775808 25200 0 +0700}
}
|
Changes to library/tzdata/Etc/GMT-8.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-8) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-8) {
{-9223372036854775808 28800 0 +0800}
}
|
Changes to library/tzdata/Etc/GMT-9.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-9) {
| | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Etc/GMT-9) {
{-9223372036854775808 32400 0 +0900}
}
|
Changes to library/tzdata/Europe/Astrakhan.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Astrakhan) {
{-9223372036854775808 11532 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Astrakhan) {
{-9223372036854775808 11532 0 LMT}
{-1441249932 10800 0 +0300}
{-1247540400 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 18000 1 +0500}
{591141600 14400 0 +0400}
{606866400 10800 0 +0300}
{606870000 14400 1 +0400}
{622594800 10800 0 +0300}
{638319600 14400 1 +0400}
{654649200 10800 0 +0300}
{670374000 14400 0 +0400}
{701820000 10800 0 +0300}
{701823600 14400 1 +0400}
{717548400 10800 0 +0300}
{733273200 14400 1 +0400}
{748998000 10800 0 +0300}
{764722800 14400 1 +0400}
{780447600 10800 0 +0300}
{796172400 14400 1 +0400}
{811897200 10800 0 +0300}
{828226800 14400 1 +0400}
{846370800 10800 0 +0300}
{859676400 14400 1 +0400}
{877820400 10800 0 +0300}
{891126000 14400 1 +0400}
{909270000 10800 0 +0300}
{922575600 14400 1 +0400}
{941324400 10800 0 +0300}
{954025200 14400 1 +0400}
{972774000 10800 0 +0300}
{985474800 14400 1 +0400}
{1004223600 10800 0 +0300}
{1017529200 14400 1 +0400}
{1035673200 10800 0 +0300}
{1048978800 14400 1 +0400}
{1067122800 10800 0 +0300}
{1080428400 14400 1 +0400}
{1099177200 10800 0 +0300}
{1111878000 14400 1 +0400}
{1130626800 10800 0 +0300}
{1143327600 14400 1 +0400}
{1162076400 10800 0 +0300}
{1174777200 14400 1 +0400}
{1193526000 10800 0 +0300}
{1206831600 14400 1 +0400}
{1224975600 10800 0 +0300}
{1238281200 14400 1 +0400}
{1256425200 10800 0 +0300}
{1269730800 14400 1 +0400}
{1288479600 10800 0 +0300}
{1301180400 14400 0 +0400}
{1414274400 10800 0 +0300}
{1459033200 14400 0 +0400}
}
|
Changes to library/tzdata/Europe/Istanbul.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
{164678400 10800 1 EEST}
{184114800 7200 0 EET}
{196214400 10800 1 EEST}
{215564400 7200 0 EET}
{228873600 10800 1 EEST}
{245804400 7200 0 EET}
{260323200 10800 1 EEST}
| | | | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
{164678400 10800 1 EEST}
{184114800 7200 0 EET}
{196214400 10800 1 EEST}
{215564400 7200 0 EET}
{228873600 10800 1 EEST}
{245804400 7200 0 EET}
{260323200 10800 1 EEST}
{267919200 10800 0 +0300}
{277254000 10800 0 +0300}
{428454000 14400 1 +0400}
{433893600 10800 0 +0300}
{468111600 7200 0 EET}
{482799600 10800 1 EEST}
{496710000 7200 0 EET}
{512521200 10800 1 EEST}
{528246000 7200 0 EET}
{543970800 10800 1 EEST}
{559695600 7200 0 EET}
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 |
{1396141200 7200 0 EET}
{1396227600 10800 0 EEST}
{1414285200 7200 0 EET}
{1427590800 10800 1 EEST}
{1445734800 10800 1 EEST}
{1446944400 7200 0 EET}
{1459040400 10800 1 EEST}
| | | 117 118 119 120 121 122 123 124 125 |
{1396141200 7200 0 EET}
{1396227600 10800 0 EEST}
{1414285200 7200 0 EET}
{1427590800 10800 1 EEST}
{1445734800 10800 1 EEST}
{1446944400 7200 0 EET}
{1459040400 10800 1 EEST}
{1473199200 10800 0 +0300}
}
|
Changes to library/tzdata/Europe/Kaliningrad.
| ︙ | ︙ | |||
77 78 79 80 81 82 83 |
{1193529600 7200 0 EET}
{1206835200 10800 1 EEST}
{1224979200 7200 0 EET}
{1238284800 10800 1 EEST}
{1256428800 7200 0 EET}
{1269734400 10800 1 EEST}
{1288483200 7200 0 EET}
| | | 77 78 79 80 81 82 83 84 85 86 |
{1193529600 7200 0 EET}
{1206835200 10800 1 EEST}
{1224979200 7200 0 EET}
{1238284800 10800 1 EEST}
{1256428800 7200 0 EET}
{1269734400 10800 1 EEST}
{1288483200 7200 0 EET}
{1301184000 10800 0 +0300}
{1414278000 7200 0 EET}
}
|
Changes to library/tzdata/Europe/Kirov.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Kirov) {
{-9223372036854775808 11928 0 LMT}
| | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Kirov) {
{-9223372036854775808 11928 0 LMT}
{-1593820800 10800 0 +0300}
{-1247540400 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 18000 1 +0500}
{591141600 14400 0 +0400}
{606866400 10800 0 MSD}
{606870000 14400 1 MSD}
{622594800 10800 0 MSK}
{638319600 14400 1 MSD}
{654649200 10800 0 MSK}
{670374000 14400 0 +0400}
{701820000 10800 0 MSD}
{701823600 14400 1 MSD}
{717548400 10800 0 MSK}
{733273200 14400 1 MSD}
{748998000 10800 0 MSK}
{764722800 14400 1 MSD}
{780447600 10800 0 MSK}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Lisbon.
1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Lisbon) {
{-9223372036854775808 -2205 0 LMT}
{-2713908195 -2205 0 LMT}
{-1830384000 0 0 WET}
{-1689555600 3600 1 WEST}
{-1677801600 0 0 WET}
| | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Lisbon) {
{-9223372036854775808 -2205 0 LMT}
{-2713908195 -2205 0 LMT}
{-1830384000 0 0 WET}
{-1689555600 3600 1 WEST}
{-1677801600 0 0 WET}
{-1667433600 3600 1 WEST}
{-1647738000 0 0 WET}
{-1635897600 3600 1 WEST}
{-1616202000 0 0 WET}
{-1604361600 3600 1 WEST}
{-1584666000 0 0 WET}
{-1572739200 3600 1 WEST}
{-1553043600 0 0 WET}
{-1541203200 3600 1 WEST}
{-1521507600 0 0 WET}
{-1442451600 3600 1 WEST}
{-1427677200 0 0 WET}
{-1379293200 3600 1 WEST}
{-1364778000 0 0 WET}
{-1348448400 3600 1 WEST}
{-1333328400 0 0 WET}
{-1316394000 3600 1 WEST}
{-1301274000 0 0 WET}
{-1284339600 3600 1 WEST}
|
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
{-1033347600 3600 1 WEST}
{-1017622800 0 0 WET}
{-1002502800 3600 1 WEST}
{-986173200 0 0 WET}
{-969238800 3600 1 WEST}
{-950490000 0 0 WET}
{-942022800 3600 1 WEST}
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
{-1033347600 3600 1 WEST}
{-1017622800 0 0 WET}
{-1002502800 3600 1 WEST}
{-986173200 0 0 WET}
{-969238800 3600 1 WEST}
{-950490000 0 0 WET}
{-942022800 3600 1 WEST}
{-922496400 0 0 WET}
{-906944400 3600 1 WEST}
{-891133200 0 0 WET}
{-877309200 3600 1 WEST}
{-873684000 7200 1 WEMT}
{-864007200 3600 1 WEST}
{-857955600 0 0 WET}
{-845859600 3600 1 WEST}
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
{-228348000 0 0 WET}
{-212623200 3600 1 WEST}
{-196898400 0 0 WET}
{-181173600 3600 1 WEST}
{-165448800 0 0 WET}
{-149724000 3600 1 WEST}
{-133999200 0 0 WET}
| | > > | | | | | | | | | | | | | > | | 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 |
{-228348000 0 0 WET}
{-212623200 3600 1 WEST}
{-196898400 0 0 WET}
{-181173600 3600 1 WEST}
{-165448800 0 0 WET}
{-149724000 3600 1 WEST}
{-133999200 0 0 WET}
{-118274400 3600 1 WEST}
{-102549600 3600 0 CET}
{212544000 0 0 WET}
{212547600 0 0 WET}
{228268800 3600 1 WEST}
{243993600 0 0 WET}
{260326800 3600 1 WEST}
{276051600 0 0 WET}
{291776400 3600 1 WEST}
{307501200 0 0 WET}
{323830800 3600 1 WEST}
{338950800 0 0 WET}
{354672000 3600 1 WEST}
{370396800 0 0 WET}
{386121600 3600 1 WEST}
{401846400 0 0 WET}
{417571200 3600 1 WEST}
{433296000 0 0 WET}
{449020800 3600 1 WEST}
{465350400 0 0 WET}
{481075200 3600 1 WEST}
{496800000 0 0 WET}
{504921600 0 0 WET}
{512528400 3600 1 WEST}
{528253200 0 0 WET}
{543978000 3600 1 WEST}
{559702800 0 0 WET}
{575427600 3600 1 WEST}
{591152400 0 0 WET}
{606877200 3600 1 WEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Minsk.
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
{1193529600 7200 0 EET}
{1206835200 10800 1 EEST}
{1224979200 7200 0 EET}
{1238284800 10800 1 EEST}
{1256428800 7200 0 EET}
{1269734400 10800 1 EEST}
{1288483200 7200 0 EET}
| | | 67 68 69 70 71 72 73 74 75 |
{1193529600 7200 0 EET}
{1206835200 10800 1 EEST}
{1224979200 7200 0 EET}
{1238284800 10800 1 EEST}
{1256428800 7200 0 EET}
{1269734400 10800 1 EEST}
{1288483200 7200 0 EET}
{1301184000 10800 0 +0300}
}
|
Changes to library/tzdata/Europe/Samara.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Samara) {
{-9223372036854775808 12020 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Samara) {
{-9223372036854775808 12020 0 LMT}
{-1593820800 10800 0 +0300}
{-1247540400 14400 0 +0400}
{-1102305600 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 18000 1 +0500}
{591141600 14400 0 +0400}
{606866400 10800 0 +0300}
{606870000 14400 1 +0400}
{622594800 10800 0 +0300}
{638319600 14400 1 +0400}
{654649200 10800 0 +0300}
{670374000 7200 0 +0200}
{670377600 10800 1 +0300}
{686102400 10800 0 +0300}
{687916800 14400 0 +0400}
{701820000 18000 1 +0500}
{717544800 14400 0 +0400}
{733269600 18000 1 +0500}
{748994400 14400 0 +0400}
{764719200 18000 1 +0500}
{780444000 14400 0 +0400}
{796168800 18000 1 +0500}
{811893600 14400 0 +0400}
{828223200 18000 1 +0500}
{846367200 14400 0 +0400}
{859672800 18000 1 +0500}
{877816800 14400 0 +0400}
{891122400 18000 1 +0500}
{909266400 14400 0 +0400}
{922572000 18000 1 +0500}
{941320800 14400 0 +0400}
{954021600 18000 1 +0500}
{972770400 14400 0 +0400}
{985471200 18000 1 +0500}
{1004220000 14400 0 +0400}
{1017525600 18000 1 +0500}
{1035669600 14400 0 +0400}
{1048975200 18000 1 +0500}
{1067119200 14400 0 +0400}
{1080424800 18000 1 +0500}
{1099173600 14400 0 +0400}
{1111874400 18000 1 +0500}
{1130623200 14400 0 +0400}
{1143324000 18000 1 +0500}
{1162072800 14400 0 +0400}
{1174773600 18000 1 +0500}
{1193522400 14400 0 +0400}
{1206828000 18000 1 +0500}
{1224972000 14400 0 +0400}
{1238277600 18000 1 +0500}
{1256421600 14400 0 +0400}
{1269727200 10800 0 +0300}
{1269730800 14400 1 +0400}
{1288479600 10800 0 +0300}
{1301180400 14400 0 +0400}
}
|
Changes to library/tzdata/Europe/Saratov.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Saratov) {
{-9223372036854775808 11058 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Saratov) {
{-9223372036854775808 11058 0 LMT}
{-1593820800 10800 0 +0300}
{-1247540400 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 10800 0 +0300}
{575420400 14400 1 +0400}
{591145200 10800 0 +0300}
{606870000 14400 1 +0400}
{622594800 10800 0 +0300}
{638319600 14400 1 +0400}
{654649200 10800 0 +0300}
{670374000 14400 0 +0400}
{701820000 10800 0 +0300}
{701823600 14400 1 +0400}
{717548400 10800 0 +0300}
{733273200 14400 1 +0400}
{748998000 10800 0 +0300}
{764722800 14400 1 +0400}
{780447600 10800 0 +0300}
{796172400 14400 1 +0400}
{811897200 10800 0 +0300}
{828226800 14400 1 +0400}
{846370800 10800 0 +0300}
{859676400 14400 1 +0400}
{877820400 10800 0 +0300}
{891126000 14400 1 +0400}
{909270000 10800 0 +0300}
{922575600 14400 1 +0400}
{941324400 10800 0 +0300}
{954025200 14400 1 +0400}
{972774000 10800 0 +0300}
{985474800 14400 1 +0400}
{1004223600 10800 0 +0300}
{1017529200 14400 1 +0400}
{1035673200 10800 0 +0300}
{1048978800 14400 1 +0400}
{1067122800 10800 0 +0300}
{1080428400 14400 1 +0400}
{1099177200 10800 0 +0300}
{1111878000 14400 1 +0400}
{1130626800 10800 0 +0300}
{1143327600 14400 1 +0400}
{1162076400 10800 0 +0300}
{1174777200 14400 1 +0400}
{1193526000 10800 0 +0300}
{1206831600 14400 1 +0400}
{1224975600 10800 0 +0300}
{1238281200 14400 1 +0400}
{1256425200 10800 0 +0300}
{1269730800 14400 1 +0400}
{1288479600 10800 0 +0300}
{1301180400 14400 0 +0400}
{1414274400 10800 0 +0300}
{1480806000 14400 0 +0400}
}
|
Changes to library/tzdata/Europe/Ulyanovsk.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Ulyanovsk) {
{-9223372036854775808 11616 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Ulyanovsk) {
{-9223372036854775808 11616 0 LMT}
{-1593820800 10800 0 +0300}
{-1247540400 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 18000 1 +0500}
{591141600 14400 0 +0400}
{606866400 10800 0 +0300}
{606870000 14400 1 +0400}
{622594800 10800 0 +0300}
{638319600 14400 1 +0400}
{654649200 10800 0 +0300}
{670374000 7200 0 +0200}
{670377600 10800 1 +0300}
{686102400 7200 0 +0200}
{695779200 10800 0 +0300}
{701823600 14400 1 +0400}
{717548400 10800 0 +0300}
{733273200 14400 1 +0400}
{748998000 10800 0 +0300}
{764722800 14400 1 +0400}
{780447600 10800 0 +0300}
{796172400 14400 1 +0400}
{811897200 10800 0 +0300}
{828226800 14400 1 +0400}
{846370800 10800 0 +0300}
{859676400 14400 1 +0400}
{877820400 10800 0 +0300}
{891126000 14400 1 +0400}
{909270000 10800 0 +0300}
{922575600 14400 1 +0400}
{941324400 10800 0 +0300}
{954025200 14400 1 +0400}
{972774000 10800 0 +0300}
{985474800 14400 1 +0400}
{1004223600 10800 0 +0300}
{1017529200 14400 1 +0400}
{1035673200 10800 0 +0300}
{1048978800 14400 1 +0400}
{1067122800 10800 0 +0300}
{1080428400 14400 1 +0400}
{1099177200 10800 0 +0300}
{1111878000 14400 1 +0400}
{1130626800 10800 0 +0300}
{1143327600 14400 1 +0400}
{1162076400 10800 0 +0300}
{1174777200 14400 1 +0400}
{1193526000 10800 0 +0300}
{1206831600 14400 1 +0400}
{1224975600 10800 0 +0300}
{1238281200 14400 1 +0400}
{1256425200 10800 0 +0300}
{1269730800 14400 1 +0400}
{1288479600 10800 0 +0300}
{1301180400 14400 0 +0400}
{1414274400 10800 0 +0300}
{1459033200 14400 0 +0400}
}
|
Changes to library/tzdata/Europe/Volgograd.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Volgograd) {
{-9223372036854775808 10660 0 LMT}
| | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Volgograd) {
{-9223372036854775808 10660 0 LMT}
{-1577761060 10800 0 +0300}
{-1247540400 14400 0 +0400}
{-256881600 14400 0 +0400}
{354916800 18000 1 +0500}
{370724400 14400 0 +0400}
{386452800 18000 1 +0500}
{402260400 14400 0 +0400}
{417988800 18000 1 +0500}
{433796400 14400 0 +0400}
{449611200 18000 1 +0500}
{465343200 14400 0 +0400}
{481068000 18000 1 +0500}
{496792800 14400 0 +0400}
{512517600 18000 1 +0500}
{528242400 14400 0 +0400}
{543967200 18000 1 +0500}
{559692000 14400 0 +0400}
{575416800 10800 0 MSD}
{575420400 14400 1 MSD}
{591145200 10800 0 MSK}
{606870000 14400 1 MSD}
{622594800 10800 0 MSK}
{638319600 14400 1 MSD}
{654649200 10800 0 MSK}
{670374000 14400 0 +0400}
{701820000 10800 0 MSD}
{701823600 14400 1 MSD}
{717548400 10800 0 MSK}
{733273200 14400 1 MSD}
{748998000 10800 0 MSK}
{764722800 14400 1 MSD}
{780447600 10800 0 MSK}
|
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
{1224975600 10800 0 MSK}
{1238281200 14400 1 MSD}
{1256425200 10800 0 MSK}
{1269730800 14400 1 MSD}
{1288479600 10800 0 MSK}
{1301180400 14400 0 MSK}
{1414274400 10800 0 MSK}
| | | 64 65 66 67 68 69 70 71 72 73 |
{1224975600 10800 0 MSK}
{1238281200 14400 1 MSD}
{1256425200 10800 0 MSK}
{1269730800 14400 1 MSD}
{1288479600 10800 0 MSK}
{1301180400 14400 0 MSK}
{1414274400 10800 0 MSK}
{1540681200 14400 0 +0400}
{1609020000 10800 0 MSK}
}
|
Changes to library/tzdata/HST.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Honolulu)]} {
LoadTimeZoneFile Pacific/Honolulu
}
set TZData(:HST) $TZData(:Pacific/Honolulu)
|
Changes to library/tzdata/Indian/Chagos.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Chagos) {
{-9223372036854775808 17380 0 LMT}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Chagos) {
{-9223372036854775808 17380 0 LMT}
{-1988167780 18000 0 +0500}
{820436400 21600 0 +0600}
}
|
Changes to library/tzdata/Indian/Maldives.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Maldives) {
{-9223372036854775808 17640 0 LMT}
{-2840158440 17640 0 MMT}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Maldives) {
{-9223372036854775808 17640 0 LMT}
{-2840158440 17640 0 MMT}
{-315636840 18000 0 +0500}
}
|
Changes to library/tzdata/Indian/Mauritius.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Mauritius) {
{-9223372036854775808 13800 0 LMT}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Mauritius) {
{-9223372036854775808 13800 0 LMT}
{-1988164200 14400 0 +0400}
{403041600 18000 1 +0500}
{417034800 14400 0 +0400}
{1224972000 18000 1 +0500}
{1238274000 14400 0 +0400}
}
|
Changes to library/tzdata/MET.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Brussels)]} {
LoadTimeZoneFile Europe/Brussels
}
set TZData(:MET) $TZData(:Europe/Brussels)
|
Changes to library/tzdata/MST.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Phoenix)]} {
LoadTimeZoneFile America/Phoenix
}
set TZData(:MST) $TZData(:America/Phoenix)
|
Changes to library/tzdata/MST7MDT.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Denver)]} {
LoadTimeZoneFile America/Denver
}
set TZData(:MST7MDT) $TZData(:America/Denver)
|
Changes to library/tzdata/PST8PDT.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Los_Angeles)]} {
LoadTimeZoneFile America/Los_Angeles
}
set TZData(:PST8PDT) $TZData(:America/Los_Angeles)
|
Changes to library/tzdata/Pacific/Apia.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Apia) {
{-9223372036854775808 45184 0 LMT}
{-2445424384 -41216 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Apia) {
{-9223372036854775808 45184 0 LMT}
{-2445424384 -41216 0 LMT}
{-1861878784 -41400 0 -1230}
{-631110600 -39600 0 -1100}
{1285498800 -36000 1 -1000}
{1301752800 -39600 0 -1100}
{1316872800 -36000 1 -1000}
{1325239200 50400 0 +1400}
{1333202400 46800 0 +1300}
{1348927200 50400 1 +1400}
{1365256800 46800 0 +1300}
{1380376800 50400 1 +1400}
{1396706400 46800 0 +1300}
{1411826400 50400 1 +1400}
{1428156000 46800 0 +1300}
{1443276000 50400 1 +1400}
{1459605600 46800 0 +1300}
{1474725600 50400 1 +1400}
{1491055200 46800 0 +1300}
{1506175200 50400 1 +1400}
{1522504800 46800 0 +1300}
{1538229600 50400 1 +1400}
{1554559200 46800 0 +1300}
{1569679200 50400 1 +1400}
{1586008800 46800 0 +1300}
{1601128800 50400 1 +1400}
{1617458400 46800 0 +1300}
}
|
Changes to library/tzdata/Pacific/Bougainville.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Bougainville) {
{-9223372036854775808 37336 0 LMT}
{-2840178136 35312 0 PMMT}
| | | | | | 1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Bougainville) {
{-9223372036854775808 37336 0 LMT}
{-2840178136 35312 0 PMMT}
{-2366790512 36000 0 +1000}
{-868010400 32400 0 +0900}
{-768906000 36000 0 +1000}
{1419696000 39600 0 +1100}
}
|
Changes to library/tzdata/Pacific/Chatham.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Chatham) {
{-9223372036854775808 44028 0 LMT}
{-3192437628 44100 0 +1215}
{-757426500 45900 0 +1245}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Chatham) {
{-9223372036854775808 44028 0 LMT}
{-3192437628 44100 0 +1215}
{-757426500 45900 0 +1245}
{152632800 49500 1 +1345}
{162309600 45900 0 +1245}
{183477600 49500 1 +1345}
{194968800 45900 0 +1245}
{215532000 49500 1 +1345}
{226418400 45900 0 +1245}
{246981600 49500 1 +1345}
{257868000 45900 0 +1245}
{278431200 49500 1 +1345}
{289317600 45900 0 +1245}
{309880800 49500 1 +1345}
{320767200 45900 0 +1245}
{341330400 49500 1 +1345}
{352216800 45900 0 +1245}
{372780000 49500 1 +1345}
{384271200 45900 0 +1245}
{404834400 49500 1 +1345}
{415720800 45900 0 +1245}
{436284000 49500 1 +1345}
{447170400 45900 0 +1245}
{467733600 49500 1 +1345}
{478620000 45900 0 +1245}
{499183200 49500 1 +1345}
{510069600 45900 0 +1245}
{530632800 49500 1 +1345}
{541519200 45900 0 +1245}
{562082400 49500 1 +1345}
{573573600 45900 0 +1245}
{594136800 49500 1 +1345}
{605023200 45900 0 +1245}
{623772000 49500 1 +1345}
{637682400 45900 0 +1245}
{655221600 49500 1 +1345}
{669132000 45900 0 +1245}
{686671200 49500 1 +1345}
{700581600 45900 0 +1245}
{718120800 49500 1 +1345}
{732636000 45900 0 +1245}
{749570400 49500 1 +1345}
{764085600 45900 0 +1245}
{781020000 49500 1 +1345}
{795535200 45900 0 +1245}
{812469600 49500 1 +1345}
{826984800 45900 0 +1245}
{844524000 49500 1 +1345}
{858434400 45900 0 +1245}
{875973600 49500 1 +1345}
{889884000 45900 0 +1245}
{907423200 49500 1 +1345}
{921938400 45900 0 +1245}
{938872800 49500 1 +1345}
{953388000 45900 0 +1245}
{970322400 49500 1 +1345}
{984837600 45900 0 +1245}
{1002376800 49500 1 +1345}
{1016287200 45900 0 +1245}
{1033826400 49500 1 +1345}
{1047736800 45900 0 +1245}
{1065276000 49500 1 +1345}
{1079791200 45900 0 +1245}
{1096725600 49500 1 +1345}
{1111240800 45900 0 +1245}
{1128175200 49500 1 +1345}
{1142690400 45900 0 +1245}
{1159624800 49500 1 +1345}
{1174140000 45900 0 +1245}
{1191074400 49500 1 +1345}
{1207404000 45900 0 +1245}
{1222524000 49500 1 +1345}
{1238853600 45900 0 +1245}
{1253973600 49500 1 +1345}
{1270303200 45900 0 +1245}
{1285423200 49500 1 +1345}
{1301752800 45900 0 +1245}
{1316872800 49500 1 +1345}
{1333202400 45900 0 +1245}
{1348927200 49500 1 +1345}
{1365256800 45900 0 +1245}
{1380376800 49500 1 +1345}
{1396706400 45900 0 +1245}
{1411826400 49500 1 +1345}
{1428156000 45900 0 +1245}
{1443276000 49500 1 +1345}
{1459605600 45900 0 +1245}
{1474725600 49500 1 +1345}
{1491055200 45900 0 +1245}
{1506175200 49500 1 +1345}
{1522504800 45900 0 +1245}
{1538229600 49500 1 +1345}
{1554559200 45900 0 +1245}
{1569679200 49500 1 +1345}
{1586008800 45900 0 +1245}
{1601128800 49500 1 +1345}
{1617458400 45900 0 +1245}
{1632578400 49500 1 +1345}
{1648908000 45900 0 +1245}
{1664028000 49500 1 +1345}
{1680357600 45900 0 +1245}
{1695477600 49500 1 +1345}
{1712412000 45900 0 +1245}
{1727532000 49500 1 +1345}
{1743861600 45900 0 +1245}
{1758981600 49500 1 +1345}
{1775311200 45900 0 +1245}
{1790431200 49500 1 +1345}
{1806760800 45900 0 +1245}
{1821880800 49500 1 +1345}
{1838210400 45900 0 +1245}
{1853330400 49500 1 +1345}
{1869660000 45900 0 +1245}
{1885384800 49500 1 +1345}
{1901714400 45900 0 +1245}
{1916834400 49500 1 +1345}
{1933164000 45900 0 +1245}
{1948284000 49500 1 +1345}
{1964613600 45900 0 +1245}
{1979733600 49500 1 +1345}
{1996063200 45900 0 +1245}
{2011183200 49500 1 +1345}
{2027512800 45900 0 +1245}
{2042632800 49500 1 +1345}
{2058962400 45900 0 +1245}
{2074687200 49500 1 +1345}
{2091016800 45900 0 +1245}
{2106136800 49500 1 +1345}
{2122466400 45900 0 +1245}
{2137586400 49500 1 +1345}
{2153916000 45900 0 +1245}
{2169036000 49500 1 +1345}
{2185365600 45900 0 +1245}
{2200485600 49500 1 +1345}
{2216815200 45900 0 +1245}
{2232540000 49500 1 +1345}
{2248869600 45900 0 +1245}
{2263989600 49500 1 +1345}
{2280319200 45900 0 +1245}
{2295439200 49500 1 +1345}
{2311768800 45900 0 +1245}
{2326888800 49500 1 +1345}
{2343218400 45900 0 +1245}
{2358338400 49500 1 +1345}
{2374668000 45900 0 +1245}
{2389788000 49500 1 +1345}
{2406117600 45900 0 +1245}
{2421842400 49500 1 +1345}
{2438172000 45900 0 +1245}
{2453292000 49500 1 +1345}
{2469621600 45900 0 +1245}
{2484741600 49500 1 +1345}
{2501071200 45900 0 +1245}
{2516191200 49500 1 +1345}
{2532520800 45900 0 +1245}
{2547640800 49500 1 +1345}
{2563970400 45900 0 +1245}
{2579090400 49500 1 +1345}
{2596024800 45900 0 +1245}
{2611144800 49500 1 +1345}
{2627474400 45900 0 +1245}
{2642594400 49500 1 +1345}
{2658924000 45900 0 +1245}
{2674044000 49500 1 +1345}
{2690373600 45900 0 +1245}
{2705493600 49500 1 +1345}
{2721823200 45900 0 +1245}
{2736943200 49500 1 +1345}
{2753272800 45900 0 +1245}
{2768997600 49500 1 +1345}
{2785327200 45900 0 +1245}
{2800447200 49500 1 +1345}
{2816776800 45900 0 +1245}
{2831896800 49500 1 +1345}
{2848226400 45900 0 +1245}
{2863346400 49500 1 +1345}
{2879676000 45900 0 +1245}
{2894796000 49500 1 +1345}
{2911125600 45900 0 +1245}
{2926245600 49500 1 +1345}
{2942575200 45900 0 +1245}
{2958300000 49500 1 +1345}
{2974629600 45900 0 +1245}
{2989749600 49500 1 +1345}
{3006079200 45900 0 +1245}
{3021199200 49500 1 +1345}
{3037528800 45900 0 +1245}
{3052648800 49500 1 +1345}
{3068978400 45900 0 +1245}
{3084098400 49500 1 +1345}
{3100428000 45900 0 +1245}
{3116152800 49500 1 +1345}
{3132482400 45900 0 +1245}
{3147602400 49500 1 +1345}
{3163932000 45900 0 +1245}
{3179052000 49500 1 +1345}
{3195381600 45900 0 +1245}
{3210501600 49500 1 +1345}
{3226831200 45900 0 +1245}
{3241951200 49500 1 +1345}
{3258280800 45900 0 +1245}
{3273400800 49500 1 +1345}
{3289730400 45900 0 +1245}
{3305455200 49500 1 +1345}
{3321784800 45900 0 +1245}
{3336904800 49500 1 +1345}
{3353234400 45900 0 +1245}
{3368354400 49500 1 +1345}
{3384684000 45900 0 +1245}
{3399804000 49500 1 +1345}
{3416133600 45900 0 +1245}
{3431253600 49500 1 +1345}
{3447583200 45900 0 +1245}
{3462703200 49500 1 +1345}
{3479637600 45900 0 +1245}
{3494757600 49500 1 +1345}
{3511087200 45900 0 +1245}
{3526207200 49500 1 +1345}
{3542536800 45900 0 +1245}
{3557656800 49500 1 +1345}
{3573986400 45900 0 +1245}
{3589106400 49500 1 +1345}
{3605436000 45900 0 +1245}
{3620556000 49500 1 +1345}
{3636885600 45900 0 +1245}
{3652610400 49500 1 +1345}
{3668940000 45900 0 +1245}
{3684060000 49500 1 +1345}
{3700389600 45900 0 +1245}
{3715509600 49500 1 +1345}
{3731839200 45900 0 +1245}
{3746959200 49500 1 +1345}
{3763288800 45900 0 +1245}
{3778408800 49500 1 +1345}
{3794738400 45900 0 +1245}
{3809858400 49500 1 +1345}
{3826188000 45900 0 +1245}
{3841912800 49500 1 +1345}
{3858242400 45900 0 +1245}
{3873362400 49500 1 +1345}
{3889692000 45900 0 +1245}
{3904812000 49500 1 +1345}
{3921141600 45900 0 +1245}
{3936261600 49500 1 +1345}
{3952591200 45900 0 +1245}
{3967711200 49500 1 +1345}
{3984040800 45900 0 +1245}
{3999765600 49500 1 +1345}
{4016095200 45900 0 +1245}
{4031215200 49500 1 +1345}
{4047544800 45900 0 +1245}
{4062664800 49500 1 +1345}
{4078994400 45900 0 +1245}
{4094114400 49500 1 +1345}
}
|
Changes to library/tzdata/Pacific/Easter.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Easter) {
{-9223372036854775808 -26248 0 LMT}
{-2524495352 -26248 0 EMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Easter) {
{-9223372036854775808 -26248 0 LMT}
{-2524495352 -26248 0 EMT}
{-1178124152 -25200 0 -0700}
{-36619200 -21600 1 -0600}
{-23922000 -25200 0 -0700}
{-3355200 -21600 1 -0600}
{7527600 -25200 0 -0700}
{24465600 -21600 1 -0600}
{37767600 -25200 0 -0700}
{55915200 -21600 1 -0600}
{69217200 -25200 0 -0700}
{87969600 -21600 1 -0600}
{100666800 -25200 0 -0700}
{118209600 -21600 1 -0600}
{132116400 -25200 0 -0700}
{150868800 -21600 1 -0600}
{163566000 -25200 0 -0700}
{182318400 -21600 1 -0600}
{195620400 -25200 0 -0700}
{213768000 -21600 1 -0600}
{227070000 -25200 0 -0700}
{245217600 -21600 1 -0600}
{258519600 -25200 0 -0700}
{277272000 -21600 1 -0600}
{289969200 -25200 0 -0700}
{308721600 -21600 1 -0600}
{321418800 -25200 0 -0700}
{340171200 -21600 1 -0600}
{353473200 -25200 0 -0700}
{371620800 -21600 1 -0600}
{384922800 -21600 0 -0600}
{403070400 -18000 1 -0500}
{416372400 -21600 0 -0600}
{434520000 -18000 1 -0500}
{447822000 -21600 0 -0600}
{466574400 -18000 1 -0500}
{479271600 -21600 0 -0600}
{498024000 -18000 1 -0500}
{510721200 -21600 0 -0600}
{529473600 -18000 1 -0500}
{545194800 -21600 0 -0600}
{560923200 -18000 1 -0500}
{574225200 -21600 0 -0600}
{592372800 -18000 1 -0500}
{605674800 -21600 0 -0600}
{624427200 -18000 1 -0500}
{637124400 -21600 0 -0600}
{653457600 -18000 1 -0500}
{668574000 -21600 0 -0600}
{687326400 -18000 1 -0500}
{700628400 -21600 0 -0600}
{718776000 -18000 1 -0500}
{732078000 -21600 0 -0600}
{750225600 -18000 1 -0500}
{763527600 -21600 0 -0600}
{781675200 -18000 1 -0500}
{794977200 -21600 0 -0600}
{813729600 -18000 1 -0500}
{826426800 -21600 0 -0600}
{845179200 -18000 1 -0500}
{859690800 -21600 0 -0600}
{876628800 -18000 1 -0500}
{889930800 -21600 0 -0600}
{906868800 -18000 1 -0500}
{923194800 -21600 0 -0600}
{939528000 -18000 1 -0500}
{952830000 -21600 0 -0600}
{971582400 -18000 1 -0500}
{984279600 -21600 0 -0600}
{1003032000 -18000 1 -0500}
{1015729200 -21600 0 -0600}
{1034481600 -18000 1 -0500}
{1047178800 -21600 0 -0600}
{1065931200 -18000 1 -0500}
{1079233200 -21600 0 -0600}
{1097380800 -18000 1 -0500}
{1110682800 -21600 0 -0600}
{1128830400 -18000 1 -0500}
{1142132400 -21600 0 -0600}
{1160884800 -18000 1 -0500}
{1173582000 -21600 0 -0600}
{1192334400 -18000 1 -0500}
{1206846000 -21600 0 -0600}
{1223784000 -18000 1 -0500}
{1237086000 -21600 0 -0600}
{1255233600 -18000 1 -0500}
{1270350000 -21600 0 -0600}
{1286683200 -18000 1 -0500}
{1304823600 -21600 0 -0600}
{1313899200 -18000 1 -0500}
{1335668400 -21600 0 -0600}
{1346558400 -18000 1 -0500}
{1367118000 -21600 0 -0600}
{1378612800 -18000 1 -0500}
{1398567600 -21600 0 -0600}
{1410062400 -18000 1 -0500}
{1463281200 -21600 0 -0600}
{1471147200 -18000 1 -0500}
{1494730800 -21600 0 -0600}
{1502596800 -18000 1 -0500}
{1526180400 -21600 0 -0600}
{1534046400 -18000 1 -0500}
{1554606000 -21600 0 -0600}
{1567915200 -18000 1 -0500}
{1586055600 -21600 0 -0600}
{1599364800 -18000 1 -0500}
{1617505200 -21600 0 -0600}
{1630814400 -18000 1 -0500}
{1648954800 -21600 0 -0600}
{1662868800 -18000 1 -0500}
{1680404400 -21600 0 -0600}
{1693713600 -18000 1 -0500}
{1712458800 -21600 0 -0600}
{1725768000 -18000 1 -0500}
{1743908400 -21600 0 -0600}
{1757217600 -18000 1 -0500}
{1775358000 -21600 0 -0600}
{1788667200 -18000 1 -0500}
{1806807600 -21600 0 -0600}
{1820116800 -18000 1 -0500}
{1838257200 -21600 0 -0600}
{1851566400 -18000 1 -0500}
{1870311600 -21600 0 -0600}
{1883016000 -18000 1 -0500}
{1901761200 -21600 0 -0600}
{1915070400 -18000 1 -0500}
{1933210800 -21600 0 -0600}
{1946520000 -18000 1 -0500}
{1964660400 -21600 0 -0600}
{1977969600 -18000 1 -0500}
{1996110000 -21600 0 -0600}
{2009419200 -18000 1 -0500}
{2027559600 -21600 0 -0600}
{2040868800 -18000 1 -0500}
{2059614000 -21600 0 -0600}
{2072318400 -18000 1 -0500}
{2091063600 -21600 0 -0600}
{2104372800 -18000 1 -0500}
{2122513200 -21600 0 -0600}
{2135822400 -18000 1 -0500}
{2153962800 -21600 0 -0600}
{2167272000 -18000 1 -0500}
{2185412400 -21600 0 -0600}
{2198721600 -18000 1 -0500}
{2217466800 -21600 0 -0600}
{2230171200 -18000 1 -0500}
{2248916400 -21600 0 -0600}
{2262225600 -18000 1 -0500}
{2280366000 -21600 0 -0600}
{2293675200 -18000 1 -0500}
{2311815600 -21600 0 -0600}
{2325124800 -18000 1 -0500}
{2343265200 -21600 0 -0600}
{2356574400 -18000 1 -0500}
{2374714800 -21600 0 -0600}
{2388024000 -18000 1 -0500}
{2406769200 -21600 0 -0600}
{2419473600 -18000 1 -0500}
{2438218800 -21600 0 -0600}
{2451528000 -18000 1 -0500}
{2469668400 -21600 0 -0600}
{2482977600 -18000 1 -0500}
{2501118000 -21600 0 -0600}
{2514427200 -18000 1 -0500}
{2532567600 -21600 0 -0600}
{2545876800 -18000 1 -0500}
{2564017200 -21600 0 -0600}
{2577326400 -18000 1 -0500}
{2596071600 -21600 0 -0600}
{2609380800 -18000 1 -0500}
{2627521200 -21600 0 -0600}
{2640830400 -18000 1 -0500}
{2658970800 -21600 0 -0600}
{2672280000 -18000 1 -0500}
{2690420400 -21600 0 -0600}
{2703729600 -18000 1 -0500}
{2721870000 -21600 0 -0600}
{2735179200 -18000 1 -0500}
{2753924400 -21600 0 -0600}
{2766628800 -18000 1 -0500}
{2785374000 -21600 0 -0600}
{2798683200 -18000 1 -0500}
{2816823600 -21600 0 -0600}
{2830132800 -18000 1 -0500}
{2848273200 -21600 0 -0600}
{2861582400 -18000 1 -0500}
{2879722800 -21600 0 -0600}
{2893032000 -18000 1 -0500}
{2911172400 -21600 0 -0600}
{2924481600 -18000 1 -0500}
{2943226800 -21600 0 -0600}
{2955931200 -18000 1 -0500}
{2974676400 -21600 0 -0600}
{2987985600 -18000 1 -0500}
{3006126000 -21600 0 -0600}
{3019435200 -18000 1 -0500}
{3037575600 -21600 0 -0600}
{3050884800 -18000 1 -0500}
{3069025200 -21600 0 -0600}
{3082334400 -18000 1 -0500}
{3101079600 -21600 0 -0600}
{3113784000 -18000 1 -0500}
{3132529200 -21600 0 -0600}
{3145838400 -18000 1 -0500}
{3163978800 -21600 0 -0600}
{3177288000 -18000 1 -0500}
{3195428400 -21600 0 -0600}
{3208737600 -18000 1 -0500}
{3226878000 -21600 0 -0600}
{3240187200 -18000 1 -0500}
{3258327600 -21600 0 -0600}
{3271636800 -18000 1 -0500}
{3290382000 -21600 0 -0600}
{3303086400 -18000 1 -0500}
{3321831600 -21600 0 -0600}
{3335140800 -18000 1 -0500}
{3353281200 -21600 0 -0600}
{3366590400 -18000 1 -0500}
{3384730800 -21600 0 -0600}
{3398040000 -18000 1 -0500}
{3416180400 -21600 0 -0600}
{3429489600 -18000 1 -0500}
{3447630000 -21600 0 -0600}
{3460939200 -18000 1 -0500}
{3479684400 -21600 0 -0600}
{3492993600 -18000 1 -0500}
{3511134000 -21600 0 -0600}
{3524443200 -18000 1 -0500}
{3542583600 -21600 0 -0600}
{3555892800 -18000 1 -0500}
{3574033200 -21600 0 -0600}
{3587342400 -18000 1 -0500}
{3605482800 -21600 0 -0600}
{3618792000 -18000 1 -0500}
{3637537200 -21600 0 -0600}
{3650241600 -18000 1 -0500}
{3668986800 -21600 0 -0600}
{3682296000 -18000 1 -0500}
{3700436400 -21600 0 -0600}
{3713745600 -18000 1 -0500}
{3731886000 -21600 0 -0600}
{3745195200 -18000 1 -0500}
{3763335600 -21600 0 -0600}
{3776644800 -18000 1 -0500}
{3794785200 -21600 0 -0600}
{3808094400 -18000 1 -0500}
{3826839600 -21600 0 -0600}
{3839544000 -18000 1 -0500}
{3858289200 -21600 0 -0600}
{3871598400 -18000 1 -0500}
{3889738800 -21600 0 -0600}
{3903048000 -18000 1 -0500}
{3921188400 -21600 0 -0600}
{3934497600 -18000 1 -0500}
{3952638000 -21600 0 -0600}
{3965947200 -18000 1 -0500}
{3984692400 -21600 0 -0600}
{3997396800 -18000 1 -0500}
{4016142000 -21600 0 -0600}
{4029451200 -18000 1 -0500}
{4047591600 -21600 0 -0600}
{4060900800 -18000 1 -0500}
{4079041200 -21600 0 -0600}
{4092350400 -18000 1 -0500}
}
|
Changes to library/tzdata/Pacific/Efate.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Efate) {
{-9223372036854775808 40396 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Efate) {
{-9223372036854775808 40396 0 LMT}
{-1829387596 39600 0 +1100}
{125409600 43200 1 +1200}
{133876800 39600 0 +1100}
{433256400 43200 1 +1200}
{448977600 39600 0 +1100}
{464706000 43200 1 +1200}
{480427200 39600 0 +1100}
{496760400 43200 1 +1200}
{511876800 39600 0 +1100}
{528210000 43200 1 +1200}
{543931200 39600 0 +1100}
{559659600 43200 1 +1200}
{575380800 39600 0 +1100}
{591109200 43200 1 +1200}
{606830400 39600 0 +1100}
{622558800 43200 1 +1200}
{638280000 39600 0 +1100}
{654008400 43200 1 +1200}
{669729600 39600 0 +1100}
{686062800 43200 1 +1200}
{696340800 39600 0 +1100}
{719931600 43200 1 +1200}
{727790400 39600 0 +1100}
}
|
Changes to library/tzdata/Pacific/Fakaofo.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fakaofo) {
{-9223372036854775808 -41096 0 LMT}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fakaofo) {
{-9223372036854775808 -41096 0 LMT}
{-2177411704 -39600 0 -1100}
{1325242800 46800 0 +1300}
}
|
Changes to library/tzdata/Pacific/Fiji.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fiji) {
{-9223372036854775808 42944 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fiji) {
{-9223372036854775808 42944 0 LMT}
{-1709985344 43200 0 +1200}
{909842400 46800 1 +1300}
{920124000 43200 0 +1200}
{941896800 46800 1 +1300}
{951573600 43200 0 +1200}
{1259416800 46800 1 +1300}
{1269698400 43200 0 +1200}
{1287842400 46800 1 +1300}
{1299333600 43200 0 +1200}
{1319292000 46800 1 +1300}
{1327154400 43200 0 +1200}
{1350741600 46800 1 +1300}
{1358604000 43200 0 +1200}
{1382796000 46800 1 +1300}
{1390050000 43200 0 +1200}
{1414850400 46800 1 +1300}
{1421503200 43200 0 +1200}
{1446300000 46800 1 +1300}
{1452952800 43200 0 +1200}
{1478354400 46800 1 +1300}
{1484402400 43200 0 +1200}
{1509804000 46800 1 +1300}
{1515852000 43200 0 +1200}
{1541253600 46800 1 +1300}
{1547301600 43200 0 +1200}
{1573308000 46800 1 +1300}
{1578751200 43200 0 +1200}
{1608386400 46800 1 +1300}
{1610805600 43200 0 +1200}
}
|
Changes to library/tzdata/Pacific/Galapagos.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Galapagos) {
{-9223372036854775808 -21504 0 LMT}
| | | | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Galapagos) {
{-9223372036854775808 -21504 0 LMT}
{-1230746496 -18000 0 -0500}
{504939600 -21600 0 -0600}
{722930400 -18000 1 -0500}
{728888400 -21600 0 -0600}
}
|
Changes to library/tzdata/Pacific/Gambier.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Gambier) {
{-9223372036854775808 -32388 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Gambier) {
{-9223372036854775808 -32388 0 LMT}
{-1806678012 -32400 0 -0900}
}
|
Changes to library/tzdata/Pacific/Guadalcanal.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Guadalcanal) {
{-9223372036854775808 38388 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Guadalcanal) {
{-9223372036854775808 38388 0 LMT}
{-1806748788 39600 0 +1100}
}
|
Changes to library/tzdata/Pacific/Guam.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Guam) {
{-9223372036854775808 -51660 0 LMT}
{-3944626740 34740 0 LMT}
{-2177487540 36000 0 GST}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Guam) {
{-9223372036854775808 -51660 0 LMT}
{-3944626740 34740 0 LMT}
{-2177487540 36000 0 GST}
{-885549600 32400 0 +0900}
{-802256400 36000 0 GST}
{-331891200 39600 1 GDT}
{-281610000 36000 0 GST}
{-73728000 39600 1 GDT}
{-29415540 36000 0 GST}
{-16704000 39600 1 GDT}
{-10659600 36000 0 GST}
|
| ︙ | ︙ |
Changes to library/tzdata/Pacific/Kanton.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kanton) {
{-9223372036854775808 0 0 -00}
| | | | | 1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kanton) {
{-9223372036854775808 0 0 -00}
{-1020470400 -43200 0 -1200}
{307627200 -39600 0 -1100}
{788871600 46800 0 +1300}
}
|
Changes to library/tzdata/Pacific/Kiritimati.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kiritimati) {
{-9223372036854775808 -37760 0 LMT}
| | | | | 1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kiritimati) {
{-9223372036854775808 -37760 0 LMT}
{-2177415040 -38400 0 -1140}
{307622400 -36000 0 -1000}
{788868000 50400 0 +1400}
}
|
Changes to library/tzdata/Pacific/Kosrae.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kosrae) {
{-9223372036854775808 -47284 0 LMT}
{-3944631116 39116 0 LMT}
| | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kosrae) {
{-9223372036854775808 -47284 0 LMT}
{-3944631116 39116 0 LMT}
{-2177491916 39600 0 +1100}
{-1743678000 32400 0 +0900}
{-1606813200 39600 0 +1100}
{-1041418800 36000 0 +1000}
{-907408800 32400 0 +0900}
{-770634000 39600 0 +1100}
{-7988400 43200 0 +1200}
{915105600 39600 0 +1100}
}
|
Changes to library/tzdata/Pacific/Kwajalein.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kwajalein) {
{-9223372036854775808 40160 0 LMT}
| | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Kwajalein) {
{-9223372036854775808 40160 0 LMT}
{-2177492960 39600 0 +1100}
{-1041418800 36000 0 +1000}
{-907408800 32400 0 +0900}
{-817462800 39600 0 +1100}
{-7988400 -43200 0 -1200}
{745934400 43200 0 +1200}
}
|
Changes to library/tzdata/Pacific/Marquesas.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Marquesas) {
{-9223372036854775808 -33480 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Marquesas) {
{-9223372036854775808 -33480 0 LMT}
{-1806676920 -34200 0 -1030}
}
|
Changes to library/tzdata/Pacific/Nauru.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Nauru) {
{-9223372036854775808 40060 0 LMT}
{-1545131260 41400 0 +1130}
| | | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Nauru) {
{-9223372036854775808 40060 0 LMT}
{-1545131260 41400 0 +1130}
{-862918200 32400 0 +0900}
{-767350800 41400 0 +1130}
{287418600 43200 0 +1200}
}
|
Changes to library/tzdata/Pacific/Niue.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Niue) {
{-9223372036854775808 -40780 0 LMT}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Niue) {
{-9223372036854775808 -40780 0 LMT}
{-543069620 -40800 0 -1220}
{-173623200 -39600 0 -1100}
}
|
Changes to library/tzdata/Pacific/Norfolk.
1 2 3 4 5 6 7 8 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Norfolk) {
{-9223372036854775808 40312 0 LMT}
{-2177493112 40320 0 +1112}
{-599656320 41400 0 +1130}
{152029800 45000 1 +1230}
{162916200 41400 0 +1130}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Norfolk) {
{-9223372036854775808 40312 0 LMT}
{-2177493112 40320 0 +1112}
{-599656320 41400 0 +1130}
{152029800 45000 1 +1230}
{162916200 41400 0 +1130}
{1443882600 39600 0 +1100}
{1561899600 39600 0 +1100}
{1570287600 43200 1 +1200}
{1586012400 39600 0 +1100}
{1601737200 43200 1 +1200}
{1617462000 39600 0 +1100}
{1633186800 43200 1 +1200}
{1648911600 39600 0 +1100}
{1664636400 43200 1 +1200}
{1680361200 39600 0 +1100}
{1696086000 43200 1 +1200}
{1712415600 39600 0 +1100}
{1728140400 43200 1 +1200}
{1743865200 39600 0 +1100}
{1759590000 43200 1 +1200}
{1775314800 39600 0 +1100}
{1791039600 43200 1 +1200}
{1806764400 39600 0 +1100}
{1822489200 43200 1 +1200}
{1838214000 39600 0 +1100}
{1853938800 43200 1 +1200}
{1869663600 39600 0 +1100}
{1885993200 43200 1 +1200}
{1901718000 39600 0 +1100}
{1917442800 43200 1 +1200}
{1933167600 39600 0 +1100}
{1948892400 43200 1 +1200}
{1964617200 39600 0 +1100}
{1980342000 43200 1 +1200}
{1996066800 39600 0 +1100}
{2011791600 43200 1 +1200}
{2027516400 39600 0 +1100}
{2043241200 43200 1 +1200}
{2058966000 39600 0 +1100}
{2075295600 43200 1 +1200}
{2091020400 39600 0 +1100}
{2106745200 43200 1 +1200}
{2122470000 39600 0 +1100}
{2138194800 43200 1 +1200}
{2153919600 39600 0 +1100}
{2169644400 43200 1 +1200}
{2185369200 39600 0 +1100}
{2201094000 43200 1 +1200}
{2216818800 39600 0 +1100}
{2233148400 43200 1 +1200}
{2248873200 39600 0 +1100}
{2264598000 43200 1 +1200}
{2280322800 39600 0 +1100}
{2296047600 43200 1 +1200}
{2311772400 39600 0 +1100}
{2327497200 43200 1 +1200}
{2343222000 39600 0 +1100}
{2358946800 43200 1 +1200}
{2374671600 39600 0 +1100}
{2390396400 43200 1 +1200}
{2406121200 39600 0 +1100}
{2422450800 43200 1 +1200}
{2438175600 39600 0 +1100}
{2453900400 43200 1 +1200}
{2469625200 39600 0 +1100}
{2485350000 43200 1 +1200}
{2501074800 39600 0 +1100}
{2516799600 43200 1 +1200}
{2532524400 39600 0 +1100}
{2548249200 43200 1 +1200}
{2563974000 39600 0 +1100}
{2579698800 43200 1 +1200}
{2596028400 39600 0 +1100}
{2611753200 43200 1 +1200}
{2627478000 39600 0 +1100}
{2643202800 43200 1 +1200}
{2658927600 39600 0 +1100}
{2674652400 43200 1 +1200}
{2690377200 39600 0 +1100}
{2706102000 43200 1 +1200}
{2721826800 39600 0 +1100}
{2737551600 43200 1 +1200}
{2753276400 39600 0 +1100}
{2769606000 43200 1 +1200}
{2785330800 39600 0 +1100}
{2801055600 43200 1 +1200}
{2816780400 39600 0 +1100}
{2832505200 43200 1 +1200}
{2848230000 39600 0 +1100}
{2863954800 43200 1 +1200}
{2879679600 39600 0 +1100}
{2895404400 43200 1 +1200}
{2911129200 39600 0 +1100}
{2926854000 43200 1 +1200}
{2942578800 39600 0 +1100}
{2958908400 43200 1 +1200}
{2974633200 39600 0 +1100}
{2990358000 43200 1 +1200}
{3006082800 39600 0 +1100}
{3021807600 43200 1 +1200}
{3037532400 39600 0 +1100}
{3053257200 43200 1 +1200}
{3068982000 39600 0 +1100}
{3084706800 43200 1 +1200}
{3100431600 39600 0 +1100}
{3116761200 43200 1 +1200}
{3132486000 39600 0 +1100}
{3148210800 43200 1 +1200}
{3163935600 39600 0 +1100}
{3179660400 43200 1 +1200}
{3195385200 39600 0 +1100}
{3211110000 43200 1 +1200}
{3226834800 39600 0 +1100}
{3242559600 43200 1 +1200}
{3258284400 39600 0 +1100}
{3274009200 43200 1 +1200}
{3289734000 39600 0 +1100}
{3306063600 43200 1 +1200}
{3321788400 39600 0 +1100}
{3337513200 43200 1 +1200}
{3353238000 39600 0 +1100}
{3368962800 43200 1 +1200}
{3384687600 39600 0 +1100}
{3400412400 43200 1 +1200}
{3416137200 39600 0 +1100}
{3431862000 43200 1 +1200}
{3447586800 39600 0 +1100}
{3463311600 43200 1 +1200}
{3479641200 39600 0 +1100}
{3495366000 43200 1 +1200}
{3511090800 39600 0 +1100}
{3526815600 43200 1 +1200}
{3542540400 39600 0 +1100}
{3558265200 43200 1 +1200}
{3573990000 39600 0 +1100}
{3589714800 43200 1 +1200}
{3605439600 39600 0 +1100}
{3621164400 43200 1 +1200}
{3636889200 39600 0 +1100}
{3653218800 43200 1 +1200}
{3668943600 39600 0 +1100}
{3684668400 43200 1 +1200}
{3700393200 39600 0 +1100}
{3716118000 43200 1 +1200}
{3731842800 39600 0 +1100}
{3747567600 43200 1 +1200}
{3763292400 39600 0 +1100}
{3779017200 43200 1 +1200}
{3794742000 39600 0 +1100}
{3810466800 43200 1 +1200}
{3826191600 39600 0 +1100}
{3842521200 43200 1 +1200}
{3858246000 39600 0 +1100}
{3873970800 43200 1 +1200}
{3889695600 39600 0 +1100}
{3905420400 43200 1 +1200}
{3921145200 39600 0 +1100}
{3936870000 43200 1 +1200}
{3952594800 39600 0 +1100}
{3968319600 43200 1 +1200}
{3984044400 39600 0 +1100}
{4000374000 43200 1 +1200}
{4016098800 39600 0 +1100}
{4031823600 43200 1 +1200}
{4047548400 39600 0 +1100}
{4063273200 43200 1 +1200}
{4078998000 39600 0 +1100}
{4094722800 43200 1 +1200}
}
|
Changes to library/tzdata/Pacific/Noumea.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Noumea) {
{-9223372036854775808 39948 0 LMT}
| | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Noumea) {
{-9223372036854775808 39948 0 LMT}
{-1829387148 39600 0 +1100}
{250002000 43200 1 +1200}
{257342400 39600 0 +1100}
{281451600 43200 1 +1200}
{288878400 39600 0 +1100}
{849366000 43200 1 +1200}
{857228400 39600 0 +1100}
}
|
Changes to library/tzdata/Pacific/Palau.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Palau) {
{-9223372036854775808 -54124 0 LMT}
{-3944624276 32276 0 LMT}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Palau) {
{-9223372036854775808 -54124 0 LMT}
{-3944624276 32276 0 LMT}
{-2177485076 32400 0 +0900}
}
|
Changes to library/tzdata/Pacific/Pitcairn.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Pitcairn) {
{-9223372036854775808 -31220 0 LMT}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Pitcairn) {
{-9223372036854775808 -31220 0 LMT}
{-2177421580 -30600 0 -0930}
{893665800 -28800 0 -0800}
}
|
Changes to library/tzdata/Pacific/Port_Moresby.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Port_Moresby) {
{-9223372036854775808 35320 0 LMT}
{-2840176120 35312 0 PMMT}
| | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Port_Moresby) {
{-9223372036854775808 35320 0 LMT}
{-2840176120 35312 0 PMMT}
{-2366790512 36000 0 +1000}
}
|
Changes to library/tzdata/Pacific/Rarotonga.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Rarotonga) {
{-9223372036854775808 48056 0 LMT}
{-2209555256 -38344 0 LMT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Rarotonga) {
{-9223372036854775808 48056 0 LMT}
{-2209555256 -38344 0 LMT}
{-543072056 -37800 0 -1130}
{279714600 -34200 0 -1030}
{289387800 -36000 0 -1000}
{309952800 -34200 1 -1030}
{320837400 -36000 0 -1000}
{341402400 -34200 1 -1030}
{352287000 -36000 0 -1000}
{372852000 -34200 1 -1030}
{384341400 -36000 0 -1000}
{404906400 -34200 1 -1030}
{415791000 -36000 0 -1000}
{436356000 -34200 1 -1030}
{447240600 -36000 0 -1000}
{467805600 -34200 1 -1030}
{478690200 -36000 0 -1000}
{499255200 -34200 1 -1030}
{510139800 -36000 0 -1000}
{530704800 -34200 1 -1030}
{541589400 -36000 0 -1000}
{562154400 -34200 1 -1030}
{573643800 -36000 0 -1000}
{594208800 -34200 1 -1030}
{605093400 -36000 0 -1000}
{625658400 -34200 1 -1030}
{636543000 -36000 0 -1000}
{657108000 -34200 1 -1030}
{667992600 -36000 0 -1000}
}
|
Changes to library/tzdata/Pacific/Tahiti.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tahiti) {
{-9223372036854775808 -35896 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tahiti) {
{-9223372036854775808 -35896 0 LMT}
{-1806674504 -36000 0 -1000}
}
|
Changes to library/tzdata/Pacific/Tarawa.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tarawa) {
{-9223372036854775808 41524 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tarawa) {
{-9223372036854775808 41524 0 LMT}
{-2177494324 43200 0 +1200}
}
|
Changes to library/tzdata/Pacific/Tongatapu.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tongatapu) {
{-9223372036854775808 44352 0 LMT}
{-767189952 44400 0 +1220}
| | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Tongatapu) {
{-9223372036854775808 44352 0 LMT}
{-767189952 44400 0 +1220}
{-284041200 46800 0 +1300}
{915102000 46800 0 +1300}
{939214800 50400 1 +1400}
{953384400 46800 0 +1300}
{973342800 50400 1 +1400}
{980596800 46800 0 +1300}
{1004792400 50400 1 +1400}
{1012046400 46800 0 +1300}
{1478350800 50400 1 +1400}
{1484398800 46800 0 +1300}
}
|
Changes to library/tzdata/WET.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Lisbon)]} {
LoadTimeZoneFile Europe/Lisbon
}
set TZData(:WET) $TZData(:Europe/Lisbon)
|
Added libtommath/CMakeLists.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# SPDX-License-Identifier: Unlicense
#
# LibTomMath, a free open source portable number theoretic multiple-precision
# integer (MPI) library written entirely in C.
#
cmake_minimum_required(VERSION 3.10)
project(libtommath
VERSION 1.3.0
DESCRIPTION "A free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C."
HOMEPAGE_URL "https://www.libtom.net/LibTomMath"
LANGUAGES C)
# package release version
# bump if re-releasing the same VERSION + patches
# set to 1 if releasing a new VERSION
set(PACKAGE_RELEASE_VERSION 1)
#-----------------------------------------------------------------------------
# Include cmake modules
#-----------------------------------------------------------------------------
include(GNUInstallDirs)
include(CheckIPOSupported)
include(CMakePackageConfigHelpers)
# default is "No tests"
option(BUILD_TESTING "" OFF)
include(CTest)
include(sources.cmake)
#-----------------------------------------------------------------------------
# Options
#-----------------------------------------------------------------------------
option(BUILD_SHARED_LIBS "Build shared library and only the shared library if \"ON\", default is static" OFF)
#-----------------------------------------------------------------------------
# Add support for ccache if desired
#-----------------------------------------------------------------------------
find_program(CCACHE ccache)
if(CCACHE)
option(ENABLE_CCACHE "Enable ccache." ON)
endif()
# use ccache if installed
if(CCACHE AND ENABLE_CCACHE)
set(CMAKE_C_COMPILER_LAUNCHER ${CCACHE})
endif()
#-----------------------------------------------------------------------------
# Compose CFLAGS
#-----------------------------------------------------------------------------
# Some information ported from makefile_include.mk
if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES)
message(STATUS "Setting build type to 'Release' as none was specified.")
set(CMAKE_BUILD_TYPE "Release")
endif()
# We only differentiate between MSVC and GCC-compatible compilers
if(MSVC)
set(LTM_C_FLAGS -W3)
elseif(WATCOM)
set(LTM_C_FLAGS -fo=.obj -oaxt -3r -w3)
else()
set(LTM_C_FLAGS -Wall -Wsign-compare -Wextra -Wshadow
-Wdeclaration-after-statement -Wbad-function-cast -Wcast-align
-Wstrict-prototypes -Wpointer-arith -Wsystem-headers)
set(CMAKE_C_FLAGS_DEBUG "-g3")
set(CMAKE_C_FLAGS_RELEASE "-O3 -funroll-loops -fomit-frame-pointer")
set(CMAKE_C_FLAGS_RELWITHDEBINFO "-g3 -O2")
set(CMAKE_C_FLAGS_MINSIZEREL "-Os")
endif()
# What compiler do we have and what are their...uhm... peculiarities
if(CMAKE_C_COMPILER_ID MATCHES "(C|c?)lang")
list(APPEND LTM_C_FLAGS -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header)
# Clang requires at least '-O1' for dead code elimination
set(CMAKE_C_FLAGS_DEBUG "-O1 ${CMAKE_C_FLAGS_DEBUG}")
endif()
if(CMAKE_C_COMPILER MATCHES "mingw")
list(APPEND LTM_C_FLAGS -Wno-shadow -Wno-expansion-to-defined -Wno-declaration-after-statement -Wno-bad-function-cast)
endif()
if(CMAKE_SYSTEM_NAME MATCHES "Darwin")
list(APPEND LTM_C_FLAGS -Wno-nullability-completeness)
endif()
if(CMAKE_SYSTEM_NAME MATCHES "CYGWIN")
list(APPEND LTM_C_FLAGS -no-undefined)
endif()
# TODO: coverage (lgcov)
# If the user set the environment variables at generate-time, append them
# in order to allow overriding our defaults.
# ${LTM_CFLAGS} means the user passed it via sth like:
# $ cmake -DLTM_CFLAGS="foo"
list(APPEND LTM_C_FLAGS ${LTM_CFLAGS})
list(APPEND LTM_LD_FLAGS ${LTM_LDFLAGS})
#-----------------------------------------------------------------------------
# library target
#-----------------------------------------------------------------------------
add_library(${PROJECT_NAME}
${SOURCES}
${HEADERS}
)
target_include_directories(${PROJECT_NAME} PUBLIC
$<BUILD_INTERFACE:${CMAKE_CURRENT_SOURCE_DIR}>
$<INSTALL_INTERFACE:${CMAKE_INSTALL_INCLUDEDIR}/${PROJECT_NAME}>
)
target_compile_options(${PROJECT_NAME} BEFORE PRIVATE
${LTM_C_FLAGS}
)
target_link_options(${PROJECT_NAME} BEFORE PRIVATE
${LTM_LD_FLAGS}
)
set(PUBLIC_HEADERS tommath.h)
set(C89 False CACHE BOOL "(Usually maintained automatically) Enable when the library is in c89 mode to package the correct header files on install")
if(C89)
list(APPEND PUBLIC_HEADERS tommath_c89.h)
endif()
set_target_properties(${PROJECT_NAME} PROPERTIES
OUTPUT_NAME tommath
VERSION ${PROJECT_VERSION}
SOVERSION ${PROJECT_VERSION_MAJOR}
PUBLIC_HEADER "${PUBLIC_HEADERS}"
)
option(COMPILE_LTO "Build with LTO enabled")
if(COMPILE_LTO)
check_ipo_supported(RESULT COMPILER_SUPPORTS_LTO)
if(COMPILER_SUPPORTS_LTO)
set_property(TARGET ${PROJECT_NAME} PROPERTY INTERPROCEDURAL_OPTIMIZATION TRUE)
else()
message(SEND_ERROR "This compiler does not support LTO. Reconfigure ${PROJECT_NAME} with -DCOMPILE_LTO=OFF.")
endif()
endif()
#-----------------------------------------------------------------------------
# demo target
#-----------------------------------------------------------------------------
if(BUILD_TESTING)
enable_testing()
add_subdirectory(demo)
endif()
#-----------------------------------------------------------------------------
# Install/export targets and files
#-----------------------------------------------------------------------------
set(CONFIG_INSTALL_DIR "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}")
set(PROJECT_VERSION_FILE "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake")
set(PROJECT_CONFIG_FILE "${PROJECT_NAME}-config.cmake")
set(TARGETS_EXPORT_NAME "${PROJECT_NAME}Targets")
install(TARGETS ${PROJECT_NAME}
EXPORT ${TARGETS_EXPORT_NAME}
LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}
ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} COMPONENT Libraries
RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}
PUBLIC_HEADER DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}
)
# Install libtommath.pc for pkg-config if we build a shared library
if(BUILD_SHARED_LIBS)
# Let the user override the default directory of the pkg-config file (usually this shouldn't be required to be changed)
set(CMAKE_INSTALL_PKGCONFIGDIR "${CMAKE_INSTALL_LIBDIR}/pkgconfig" CACHE PATH "Folder where to install .pc files")
configure_file(
${CMAKE_CURRENT_SOURCE_DIR}/${PROJECT_NAME}.pc.in
${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc
@ONLY
)
install(FILES ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc
DESTINATION ${CMAKE_INSTALL_PKGCONFIGDIR}
)
endif()
# generate package version file
write_basic_package_version_file(
${PROJECT_VERSION_FILE}
VERSION ${PROJECT_VERSION}
COMPATIBILITY SameMajorVersion
)
# install version file
install(FILES ${PROJECT_VERSION_FILE}
DESTINATION ${CONFIG_INSTALL_DIR}
)
# build directory package config
export(EXPORT ${TARGETS_EXPORT_NAME}
FILE ${PROJECT_CONFIG_FILE}
)
# installed package config
install(EXPORT ${TARGETS_EXPORT_NAME}
DESTINATION ${CONFIG_INSTALL_DIR}
FILE ${PROJECT_CONFIG_FILE}
)
# add to CMake registry
export(PACKAGE ${PROJECT_NAME})
#---------------------------------------------------------------------------------------
# Create release packages
#---------------------------------------------------------------------------------------
# determine distribution and architecture
find_program(LSB_RELEASE lsb_release)
find_program(SYSCTL sysctl)
find_program(UNAME uname)
if(UNAME)
execute_process(COMMAND uname -m OUTPUT_VARIABLE MACHINE_ARCH OUTPUT_STRIP_TRAILING_WHITESPACE)
elseif(SYSCTL)
execute_process(COMMAND sysctl -b hw.machine_arch OUTPUT_VARIABLE MACHINE_ARCH OUTPUT_STRIP_TRAILING_WHITESPACE)
else()
string(TOLOWER ${CMAKE_SYSTEM_NAME} MACHINE_ARCH)
endif()
if(LSB_RELEASE)
execute_process(COMMAND lsb_release -si OUTPUT_VARIABLE LINUX_DISTRO OUTPUT_STRIP_TRAILING_WHITESPACE)
execute_process(COMMAND lsb_release -sc OUTPUT_VARIABLE LINUX_DISTRO_CODENAME OUTPUT_STRIP_TRAILING_WHITESPACE)
execute_process(COMMAND lsb_release -sr OUTPUT_VARIABLE LINUX_DISTRO_VERSION OUTPUT_STRIP_TRAILING_WHITESPACE)
string(TOLOWER ${LINUX_DISTRO} LINUX_DISTRO)
if(LINUX_DISTRO_CODENAME STREQUAL "n/a")
set(DISTRO_PACK_PATH ${LINUX_DISTRO}/${LINUX_DISTRO_VERSION}/)
else()
set(DISTRO_PACK_PATH ${LINUX_DISTRO}/${LINUX_DISTRO_CODENAME}/)
endif()
else()
set(DISTRO_PACK_PATH ${CMAKE_SYSTEM_NAME}/)
endif()
# make sure untagged versions get a different package name
execute_process(COMMAND git describe --exact-match --tags ERROR_QUIET RESULT_VARIABLE REPO_HAS_TAG)
if(REPO_HAS_TAG EQUAL 0)
set(PACKAGE_NAME_SUFFIX "")
else()
set(PACKAGE_NAME_SUFFIX "-git")
message(STATUS "Use -git suffix")
endif()
# default CPack generators
set(CPACK_GENERATOR TGZ STGZ)
# extra CPack generators
if(LINUX_DISTRO STREQUAL "debian" OR LINUX_DISTRO STREQUAL "ubuntu" OR LINUX_DISTRO STREQUAL "linuxmint")
list(APPEND CPACK_GENERATOR DEB)
elseif(LINUX_DISTRO STREQUAL "fedora" OR LINUX_DISTRO STREQUAL "opensuse" OR LINUX_DISTRO STREQUAL "centos")
list(APPEND CPACK_GENERATOR RPM)
elseif(CMAKE_SYSTEM_NAME STREQUAL "FreeBSD")
list(APPEND CPACK_GENERATOR FREEBSD)
endif()
set(LTM_DEBIAN_SHARED_PACKAGE_NAME "${PROJECT_NAME}${PACKAGE_NAME_SUFFIX}${PROJECT_VERSION_MAJOR}")
# general CPack config
set(CPACK_PACKAGE_DIRECTORY ${CMAKE_BINARY_DIR}/packages/${DISTRO_PACK_PATH})
message(STATUS "CPack: packages will be generated under ${CPACK_PACKAGE_DIRECTORY}")
if(BUILD_SHARED_LIBS)
set(CPACK_PACKAGE_NAME "${PROJECT_NAME}${PROJECT_VERSION_MAJOR}")
set(CPACK_DEBIAN_PACKAGE_NAME "${LTM_DEBIAN_SHARED_PACKAGE_NAME}")
else()
set(CPACK_PACKAGE_NAME "${PROJECT_NAME}-devel")
set(CPACK_DEBIAN_LIBRARIES_PACKAGE_NAME "${PROJECT_NAME}${PACKAGE_NAME_SUFFIX}-dev")
endif()
set(CPACK_PACKAGE_VERSION ${PROJECT_VERSION})
set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LibTomMath")
set(CPACK_PACKAGE_VENDOR "libtom projects")
set(CPACK_PACKAGE_CONTACT "libtom@googlegroups.com")
set(CPACK_RESOURCE_FILE_LICENSE "${PROJECT_SOURCE_DIR}/LICENSE")
set(PACKAGE_NAME_TRAILER ${CPACK_PACKAGE_VERSION}-${PACKAGE_RELEASE_VERSION}_${MACHINE_ARCH})
set(CPACK_PACKAGE_FILE_NAME ${CPACK_PACKAGE_NAME}-${PACKAGE_NAME_TRAILER})
# deb specific CPack config
set(CPACK_DEBIAN_FILE_NAME DEB-DEFAULT)
set(CPACK_DEBIAN_DEBUGINFO_PACKAGE ON)
set(CPACK_DEBIAN_PACKAGE_RELEASE ${PACKAGE_RELEASE_VERSION})
set(CPACK_DEBIAN_PACKAGE_SHLIBDEPS ON)
if(BUILD_SHARED_LIBS)
set(CPACK_DEBIAN_PACKAGE_SECTION "libs")
else()
set(CPACK_DEBIAN_PACKAGE_SECTION "devel")
set(CPACK_DEBIAN_PACKAGE_DEPENDS ${LTM_DEBIAN_SHARED_PACKAGE_NAME})
set(CPACK_DEB_COMPONENT_INSTALL ON)
set(CPACK_ARCHIVE_COMPONENT_INSTALL ON)
set(CPACK_COMPONENTS_ALL Libraries)
endif()
# rpm specific CPack config
set(CPACK_RPM_PACKAGE_RELEASE ${PACKAGE_RELEASE_VERSION})
set(CPACK_RPM_PACKAGE_ARCHITECTURE ${MACHINE_ARCH})
set(CPACK_RPM_PACKAGE_NAME "${CPACK_PACKAGE_NAME}-${PROJECT_VERSION}")
set(CPACK_RPM_PACKAGE_LICENSE "The Unlicense")
# FreeBSD specific CPack config
set(CPACK_FREEBSD_PACKAGE_MAINTAINER "gahr@FreeBSD.org")
set(CPACK_FREEBSD_PACKAGE_ORIGIN "math/libtommath")
set(CPACK_FREEBSD_PACKAGE_CATEGORIES "math")
include(CPack)
|
Changes to libtommath/appveyor.yml.
|
| | | 1 2 3 4 5 6 7 8 |
version: 1.3.0-{build}
branches:
only:
- master
- develop
- /^release/
- /^travis/
image:
|
| ︙ | ︙ |
Changes to libtommath/bn_deprecated.c.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
}
#endif
#ifdef BN_MP_BALANCE_MUL_C
mp_err mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
return s_mp_balance_mul(a, b, c);
}
#endif
#ifdef BN_MP_EXPTMOD_FAST_C
mp_err mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode)
{
return s_mp_exptmod_fast(G, X, P, Y, redmode);
}
#endif
| > > > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
}
#endif
#ifdef BN_MP_BALANCE_MUL_C
mp_err mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
return s_mp_balance_mul(a, b, c);
}
#endif
#ifdef BN_MP_DIV_3_C
mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d)
{
return s_mp_div_3(a, c, d);
}
#endif
#ifdef BN_MP_EXPTMOD_FAST_C
mp_err mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode)
{
return s_mp_exptmod_fast(G, X, P, Y, redmode);
}
#endif
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
{
return (unsigned long)mp_get_mag_ul(a);
}
#endif
#ifdef BN_MP_GET_LONG_LONG_C
unsigned long long mp_get_long_long(const mp_int *a)
{
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > > | | | | > > > > > > | 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 |
{
return (unsigned long)mp_get_mag_ul(a);
}
#endif
#ifdef BN_MP_GET_LONG_LONG_C
unsigned long long mp_get_long_long(const mp_int *a)
{
return (unsigned long long)mp_get_mag_u64(a);
}
#endif
#ifdef BN_MP_GET_LL_C
MP_GET_SIGNED(mp_get_ll, mp_get_mag_u64, long long, uint64_t)
#endif
#ifdef BN_MP_GET_MAG_ULL_C
MP_GET_MAG(mp_get_mag_ull, unsigned long long)
#endif
#ifdef BN_MP_INIT_LL_C
MP_INIT_INT(mp_init_ll, mp_set_i64, long long)
#endif
#ifdef BN_MP_SET_LL_C
MP_SET_SIGNED(mp_set_ll, mp_set_i64, long long, long long)
#endif
#ifdef BN_MP_INIT_ULL_C
MP_INIT_INT(mp_init_ull, mp_set_u64, unsigned long long)
#endif
#ifdef BN_MP_SET_ULL_C
MP_SET_UNSIGNED(mp_set_ull, unsigned long long)
#endif
#ifdef BN_MP_PRIME_IS_DIVISIBLE_C
mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result)
{
return s_mp_prime_is_divisible(a, result);
}
#endif
#ifdef BN_MP_LOG_U32_C
mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c)
{
mp_err e;
int c_;
if (base > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
e = mp_log_n(a, (int)base, &c_);
*c = (uint32_t)c_;
return e;
}
#endif
#ifdef BN_MP_EXPT_D_EX_C
mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
{
(void)fast;
if (b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
return mp_expt_n(a, (int)b, c);
}
#endif
#ifdef BN_MP_EXPT_D_C
mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c)
{
if (b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
return mp_expt_n(a, (int)b, c);
}
#endif
#ifdef BN_MP_EXPT_U32_C
mp_err mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c)
{
if (b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
return mp_expt_n(a, (int)b, c);
}
#endif
#ifdef BN_MP_N_ROOT_EX_C
mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
{
(void)fast;
if (b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
return mp_root_n(a, (int)b, c);
}
#endif
#ifdef BN_MP_N_ROOT_C
mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c)
{
if (b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
return mp_root_n(a, (int)b, c);
}
#endif
#ifdef BN_MP_ROOT_U32_C
mp_err mp_root_u32(const mp_int *a, uint32_t b, mp_int *c)
{
return mp_root_n(a, (int)b, c);
}
#endif
#ifdef BN_MP_UNSIGNED_BIN_SIZE_C
int mp_unsigned_bin_size(const mp_int *a)
{
return (int)mp_ubin_size(a);
}
|
| ︙ | ︙ |
Deleted libtommath/bn_mp_div_3.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_div_d.c.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
if (c != NULL) {
return mp_div_2d(a, ix, c, NULL);
}
return MP_OKAY;
}
/* three? */
| | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
if (c != NULL) {
return mp_div_2d(a, ix, c, NULL);
}
return MP_OKAY;
}
/* three? */
if (MP_HAS(S_MP_DIV_3) && (b == 3u)) {
return s_mp_div_3(a, c, d);
}
/* no easy answer [c'est la vie]. Just division */
if ((err = mp_init_size(&q, a->used)) != MP_OKAY) {
return err;
}
|
| ︙ | ︙ |
Added libtommath/bn_mp_expt_n.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
#include "tommath_private.h"
#ifdef BN_MP_EXPT_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* calculate c = a**b using a square-multiply algorithm */
mp_err mp_expt_n(const mp_int *a, int b, mp_int *c)
{
mp_err err;
mp_int g;
if ((err = mp_init_copy(&g, a)) != MP_OKAY) {
return err;
}
/* set initial result */
mp_set(c, 1uL);
while (b > 0) {
/* if the bit is set multiply */
if ((b & 1) != 0) {
if ((err = mp_mul(c, &g, c)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* square */
if (b > 1) {
if ((err = mp_sqr(&g, &g)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* shift to next bit */
b >>= 1;
}
LBL_ERR:
mp_clear(&g);
return err;
}
#endif
|
Deleted libtommath/bn_mp_expt_u32.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_exptmod.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
mp_int tmpG, tmpX;
mp_err err;
if (!MP_HAS(MP_INVMOD)) {
return MP_VAL;
}
| | | | 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 |
mp_int tmpG, tmpX;
mp_err err;
if (!MP_HAS(MP_INVMOD)) {
return MP_VAL;
}
if ((err = mp_init_multi(&tmpG, &tmpX, (void *)NULL)) != MP_OKAY) {
return err;
}
/* first compute 1/G mod P */
if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) {
goto LBL_ERR;
}
/* now get |X| */
if ((err = mp_abs(X, &tmpX)) != MP_OKAY) {
goto LBL_ERR;
}
/* and now compute (1/G)**|X| instead of G**X [X < 0] */
err = mp_exptmod(&tmpG, &tmpX, P, Y);
LBL_ERR:
mp_clear_multi(&tmpG, &tmpX, (void *)NULL);
return err;
}
/* modified diminished radix reduction */
if (MP_HAS(MP_REDUCE_IS_2K_L) && MP_HAS(MP_REDUCE_2K_L) && MP_HAS(S_MP_EXPTMOD) &&
(mp_reduce_is_2k_l(P) == MP_YES)) {
return s_mp_exptmod(G, X, P, Y, 1);
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_exteuclid.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
#include "tommath_private.h"
#ifdef BN_MP_EXTEUCLID_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Extended euclidean algorithm of (a, b) produces
a*u1 + b*u2 = u3
*/
mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3)
{
mp_int u1, u2, u3, v1, v2, v3, t1, t2, t3, q, tmp;
mp_err err;
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
#include "tommath_private.h"
#ifdef BN_MP_EXTEUCLID_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Extended euclidean algorithm of (a, b) produces
a*u1 + b*u2 = u3
*/
mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3)
{
mp_int u1, u2, u3, v1, v2, v3, t1, t2, t3, q, tmp;
mp_err err;
if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, (void *)NULL)) != MP_OKAY) {
return err;
}
/* initialize, (u1,u2,u3) = (1,0,a) */
mp_set(&u1, 1uL);
if ((err = mp_copy(a, &u3)) != MP_OKAY) goto LBL_ERR;
|
| ︙ | ︙ | |||
63 64 65 66 67 68 69 |
}
if (U3 != NULL) {
mp_exch(U3, &u3);
}
err = MP_OKAY;
LBL_ERR:
| | | 63 64 65 66 67 68 69 70 71 72 73 |
}
if (U3 != NULL) {
mp_exch(U3, &u3);
}
err = MP_OKAY;
LBL_ERR:
mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, (void *)NULL);
return err;
}
#endif
|
Deleted libtommath/bn_mp_get_ll.c.
|
| < < < < < < < |
Deleted libtommath/bn_mp_get_mag_ull.c.
|
| < < < < < < < |
Deleted libtommath/bn_mp_init_ll.c.
|
| < < < < < < < |
Deleted libtommath/bn_mp_init_ull.c.
|
| < < < < < < < |
Changes to libtommath/bn_mp_lcm.c.
1 2 3 4 5 6 7 8 9 10 11 12 |
#include "tommath_private.h"
#ifdef BN_MP_LCM_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes least common multiple as |a*b|/(a, b) */
mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_err err;
mp_int t1, t2;
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
#include "tommath_private.h"
#ifdef BN_MP_LCM_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes least common multiple as |a*b|/(a, b) */
mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_err err;
mp_int t1, t2;
if ((err = mp_init_multi(&t1, &t2, (void *)NULL)) != MP_OKAY) {
return err;
}
/* t1 = get the GCD of the two inputs */
if ((err = mp_gcd(a, b, &t1)) != MP_OKAY) {
goto LBL_T;
}
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
err = mp_mul(a, &t2, c);
}
/* fix the sign to positive */
c->sign = MP_ZPOS;
LBL_T:
| | | 34 35 36 37 38 39 40 41 42 43 44 |
err = mp_mul(a, &t2, c);
}
/* fix the sign to positive */
c->sign = MP_ZPOS;
LBL_T:
mp_clear_multi(&t1, &t2, (void *)NULL);
return err;
}
#endif
|
Added libtommath/bn_mp_log_n.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
#include "tommath_private.h"
#ifdef BN_MP_LOG_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
mp_err mp_log_n(const mp_int *a, int base, int *c)
{
if (mp_isneg(a) || mp_iszero(a) || (base < 2) || (unsigned)base > (unsigned)MP_DIGIT_MAX) {
return MP_VAL;
}
if (MP_HAS(S_MP_LOG_2EXPT) && MP_IS_2EXPT((mp_digit)base)) {
*c = s_mp_log_2expt(a, (mp_digit)base);
return MP_OKAY;
}
if (MP_HAS(S_MP_LOG_D) && (a->used == 1)) {
*c = s_mp_log_d((mp_digit)base, a->dp[0]);
return MP_OKAY;
}
if (MP_HAS(S_MP_LOG)) {
return s_mp_log(a, (mp_digit)base, c);
}
return MP_VAL;
}
#endif
|
Deleted libtommath/bn_mp_log_u32.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_prime_frobenius_underwood.c.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | mp_int T1z, T2z, Np1z, sz, tz; int a, ap2, length, i, j; mp_err err; *result = MP_NO; | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
mp_int T1z, T2z, Np1z, sz, tz;
int a, ap2, length, i, j;
mp_err err;
*result = MP_NO;
if ((err = mp_init_multi(&T1z, &T2z, &Np1z, &sz, &tz, (void *)NULL)) != MP_OKAY) {
return err;
}
for (a = 0; a < LTM_FROBENIUS_UNDERWOOD_A; a++) {
/* TODO: That's ugly! No, really, it is! */
if ((a==2) || (a==4) || (a==7) || (a==8) || (a==10) ||
(a==14) || (a==18) || (a==23) || (a==26) || (a==28)) {
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
mp_set_u32(&T1z, (uint32_t)((2 * a) + 5));
if ((err = mp_mod(&T1z, N, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if (MP_IS_ZERO(&sz) && (mp_cmp(&tz, &T1z) == MP_EQ)) {
*result = MP_YES;
}
LBL_FU_ERR:
| | | 120 121 122 123 124 125 126 127 128 129 130 131 132 |
mp_set_u32(&T1z, (uint32_t)((2 * a) + 5));
if ((err = mp_mod(&T1z, N, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if (MP_IS_ZERO(&sz) && (mp_cmp(&tz, &T1z) == MP_EQ)) {
*result = MP_YES;
}
LBL_FU_ERR:
mp_clear_multi(&tz, &sz, &Np1z, &T2z, &T1z, (void *)NULL);
return err;
}
#endif
#endif
|
Changes to libtommath/bn_mp_prime_rand.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
/* MP_PRIME_SAFE implies MP_PRIME_BBS */
if ((flags & MP_PRIME_SAFE) != 0) {
flags |= MP_PRIME_BBS;
}
/* calc the byte size */
| | > > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
/* MP_PRIME_SAFE implies MP_PRIME_BBS */
if ((flags & MP_PRIME_SAFE) != 0) {
flags |= MP_PRIME_BBS;
}
/* calc the byte size */
bsize = (size>>3);
if (size&7) {
bsize++;
}
/* we need a buffer of bsize bytes */
tmp = (unsigned char *) MP_MALLOC((size_t)bsize);
if (tmp == NULL) {
return MP_MEM;
}
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_prime_strong_lucas_selfridge.c.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | such that Jacobi(D,N) = -1 (Selfridge's algorithm). Theory indicates that, if N is not a perfect square, D will "nearly always" be "small." Just in case, an overflow trap for D is included. */ if ((err = mp_init_multi(&Dz, &gcd, &Np1, &Uz, &Vz, &U2mz, &V2mz, &Qmz, &Q2mz, &Qkdz, &T1z, &T2z, &T3z, &T4z, &Q2kdz, | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
such that Jacobi(D,N) = -1 (Selfridge's algorithm). Theory
indicates that, if N is not a perfect square, D will "nearly
always" be "small." Just in case, an overflow trap for D is
included.
*/
if ((err = mp_init_multi(&Dz, &gcd, &Np1, &Uz, &Vz, &U2mz, &V2mz, &Qmz, &Q2mz, &Qkdz, &T1z, &T2z, &T3z, &T4z, &Q2kdz,
(void *)NULL)) != MP_OKAY) {
return err;
}
D = 5;
sign = 1;
for (;;) {
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
if (r < (s - 1)) {
if ((err = mp_sqr(&Qkdz, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) goto LBL_LS_ERR;
}
}
LBL_LS_ERR:
| | | 277 278 279 280 281 282 283 284 285 286 287 288 289 |
if (r < (s - 1)) {
if ((err = mp_sqr(&Qkdz, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) goto LBL_LS_ERR;
}
}
LBL_LS_ERR:
mp_clear_multi(&Q2kdz, &T4z, &T3z, &T2z, &T1z, &Qkdz, &Q2mz, &Qmz, &V2mz, &U2mz, &Vz, &Uz, &Np1, &gcd, &Dz, (void *)NULL);
return err;
}
#endif
#endif
#endif
|
Added libtommath/bn_mp_root_n.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 |
#include "tommath_private.h"
#ifdef BN_MP_ROOT_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* find the n'th root of an integer
*
* Result found such that (c)**b <= a and (c+1)**b > a
*
* This algorithm uses Newton's approximation
* x[i+1] = x[i] - f(x[i])/f'(x[i])
* which will find the root in log(N) time where
* each step involves a fair bit.
*/
mp_err mp_root_n(const mp_int *a, int b, mp_int *c)
{
mp_int t1, t2, t3, a_;
int ilog2;
mp_err err;
if ((unsigned)b > (unsigned)MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
/* input must be positive if b is even */
if (((b & 1) == 0) && mp_isneg(a)) {
return MP_VAL;
}
if ((err = mp_init_multi(&t1, &t2, &t3, (void *)NULL)) != MP_OKAY) {
return err;
}
/* if a is negative fudge the sign but keep track */
a_ = *a;
a_.sign = MP_ZPOS;
/* Compute seed: 2^(log_2(n)/b + 2)*/
ilog2 = mp_count_bits(a);
/*
If "b" is larger than INT_MAX it is also larger than
log_2(n) because the bit-length of the "n" is measured
with an int and hence the root is always < 2 (two).
*/
if (b > INT_MAX/2) {
mp_set(c, 1uL);
c->sign = a->sign;
err = MP_OKAY;
goto LBL_ERR;
}
/* "b" is smaller than INT_MAX, we can cast safely */
if (ilog2 < b) {
mp_set(c, 1uL);
c->sign = a->sign;
err = MP_OKAY;
goto LBL_ERR;
}
ilog2 = ilog2 / b;
if (ilog2 == 0) {
mp_set(c, 1uL);
c->sign = a->sign;
err = MP_OKAY;
goto LBL_ERR;
}
/* Start value must be larger than root */
ilog2 += 2;
if ((err = mp_2expt(&t2,ilog2)) != MP_OKAY) goto LBL_ERR;
do {
/* t1 = t2 */
if ((err = mp_copy(&t2, &t1)) != MP_OKAY) goto LBL_ERR;
/* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */
/* t3 = t1**(b-1) */
if ((err = mp_expt_n(&t1, b - 1, &t3)) != MP_OKAY) goto LBL_ERR;
/* numerator */
/* t2 = t1**b */
if ((err = mp_mul(&t3, &t1, &t2)) != MP_OKAY) goto LBL_ERR;
/* t2 = t1**b - a */
if ((err = mp_sub(&t2, &a_, &t2)) != MP_OKAY) goto LBL_ERR;
/* denominator */
/* t3 = t1**(b-1) * b */
if ((err = mp_mul_d(&t3, (mp_digit)b, &t3)) != MP_OKAY) goto LBL_ERR;
/* t3 = (t1**b - a)/(b * t1**(b-1)) */
if ((err = mp_div(&t2, &t3, &t3, NULL)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&t1, &t3, &t2)) != MP_OKAY) goto LBL_ERR;
/*
Number of rounds is at most log_2(root). If it is more it
got stuck, so break out of the loop and do the rest manually.
*/
if (ilog2-- == 0) {
break;
}
} while (mp_cmp(&t1, &t2) != MP_EQ);
/* result can be off by a few so check */
/* Loop beneath can overshoot by one if found root is smaller than actual root */
for (;;) {
mp_ord cmp;
if ((err = mp_expt_n(&t1, b, &t2)) != MP_OKAY) goto LBL_ERR;
cmp = mp_cmp(&t2, &a_);
if (cmp == MP_EQ) {
err = MP_OKAY;
goto LBL_ERR;
}
if (cmp == MP_LT) {
if ((err = mp_add_d(&t1, 1uL, &t1)) != MP_OKAY) goto LBL_ERR;
} else {
break;
}
}
/* correct overshoot from above or from recurrence */
for (;;) {
if ((err = mp_expt_n(&t1, b, &t2)) != MP_OKAY) goto LBL_ERR;
if (mp_cmp(&t2, &a_) == MP_GT) {
if ((err = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto LBL_ERR;
} else {
break;
}
}
/* set the result */
mp_exch(&t1, c);
/* set the sign of the result */
c->sign = a->sign;
LBL_ERR:
mp_clear_multi(&t1, &t2, &t3, (void *)NULL);
return err;
}
#endif
|
Deleted libtommath/bn_mp_root_u32.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_set_double.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
union {
double dbl;
uint64_t bits;
} cast;
cast.dbl = b;
exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFu);
| | | | 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 |
union {
double dbl;
uint64_t bits;
} cast;
cast.dbl = b;
exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFu);
frac = (cast.bits & ((1uLL << 52) - 1uLL)) | (1uLL << 52);
if (exp == 0x7FF) { /* +-inf, NaN */
return MP_VAL;
}
exp -= 1023 + 52;
mp_set_u64(a, frac);
err = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a);
if (err != MP_OKAY) {
return err;
}
if (((cast.bits >> 63) != 0uLL) && !MP_IS_ZERO(a)) {
a->sign = MP_NEG;
}
return MP_OKAY;
}
#else
/* pragma message() not supported by several compilers (in mostly older but still used versions) */
|
| ︙ | ︙ |
Deleted libtommath/bn_mp_set_ll.c.
|
| < < < < < < < |
Deleted libtommath/bn_mp_set_ull.c.
|
| < < < < < < < |
Changes to libtommath/bn_mp_sqrtmod_prime.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 |
mp_zero(ret);
return MP_OKAY;
}
if (mp_cmp_d(prime, 2uL) == MP_EQ) return MP_VAL; /* prime must be odd */
if ((err = mp_kronecker(n, prime, &legendre)) != MP_OKAY) return err;
if (legendre == -1) return MP_VAL; /* quadratic non-residue mod prime */
| | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
mp_zero(ret);
return MP_OKAY;
}
if (mp_cmp_d(prime, 2uL) == MP_EQ) return MP_VAL; /* prime must be odd */
if ((err = mp_kronecker(n, prime, &legendre)) != MP_OKAY) return err;
if (legendre == -1) return MP_VAL; /* quadratic non-residue mod prime */
if ((err = mp_init_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, (void *)NULL)) != MP_OKAY) {
return err;
}
/* SPECIAL CASE: if prime mod 4 == 3
* compute directly: err = n^(prime+1)/4 mod prime
* Handbook of Applied Cryptography algorithm 3.36
*/
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
if ((err = mp_mulmod(&T, &C, prime, &T)) != MP_OKAY) goto cleanup;
/* T = (T * C) mod prime */
mp_set(&M, i);
/* M = i */
}
cleanup:
| | | 107 108 109 110 111 112 113 114 115 116 117 118 |
if ((err = mp_mulmod(&T, &C, prime, &T)) != MP_OKAY) goto cleanup;
/* T = (T * C) mod prime */
mp_set(&M, i);
/* M = i */
}
cleanup:
mp_clear_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, (void *)NULL);
return err;
}
#endif
|
Added libtommath/bn_s_mp_div_3.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 |
#include "tommath_private.h"
#ifdef BN_S_MP_DIV_3_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* divide by three (based on routine from MPI and the GMP manual) */
mp_err s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *d)
{
mp_int q;
mp_word w, t;
mp_digit b;
mp_err err;
int ix;
/* b = 2**MP_DIGIT_BIT / 3 */
b = ((mp_word)1 << (mp_word)MP_DIGIT_BIT) / (mp_word)3;
if ((err = mp_init_size(&q, a->used)) != MP_OKAY) {
return err;
}
q.used = a->used;
q.sign = a->sign;
w = 0;
for (ix = a->used - 1; ix >= 0; ix--) {
w = (w << (mp_word)MP_DIGIT_BIT) | (mp_word)a->dp[ix];
if (w >= 3u) {
/* multiply w by [1/3] */
t = (w * (mp_word)b) >> (mp_word)MP_DIGIT_BIT;
/* now subtract 3 * [w/3] from w, to get the remainder */
w -= t+t+t;
/* fixup the remainder as required since
* the optimization is not exact.
*/
while (w >= 3u) {
t += 1u;
w -= 3u;
}
} else {
t = 0;
}
q.dp[ix] = (mp_digit)t;
}
/* [optional] store the remainder */
if (d != NULL) {
*d = (mp_digit)w;
}
/* [optional] store the quotient */
if (c != NULL) {
mp_clamp(&q);
mp_exch(&q, c);
}
mp_clear(&q);
return err;
}
#endif
|
Changes to libtommath/bn_s_mp_invmod_fast.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
/* 2. [modified] b must be odd */
if (MP_IS_EVEN(b)) {
return MP_VAL;
}
/* init all our temps */
| | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
/* 2. [modified] b must be odd */
if (MP_IS_EVEN(b)) {
return MP_VAL;
}
/* init all our temps */
if ((err = mp_init_multi(&x, &y, &u, &v, &B, &D, (void *)NULL)) != MP_OKAY) {
return err;
}
/* x == modulus, y == value to invert */
if ((err = mp_copy(b, &x)) != MP_OKAY) goto LBL_ERR;
/* we need y = |a| */
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 | } mp_exch(&D, c); c->sign = neg; err = MP_OKAY; LBL_ERR: | | | 108 109 110 111 112 113 114 115 116 117 118 | } mp_exch(&D, c); c->sign = neg; err = MP_OKAY; LBL_ERR: mp_clear_multi(&x, &y, &u, &v, &B, &D, (void *)NULL); return err; } #endif |
Changes to libtommath/bn_s_mp_invmod_slow.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
/* b cannot be negative */
if ((b->sign == MP_NEG) || MP_IS_ZERO(b)) {
return MP_VAL;
}
/* init temps */
if ((err = mp_init_multi(&x, &y, &u, &v,
| | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
/* b cannot be negative */
if ((b->sign == MP_NEG) || MP_IS_ZERO(b)) {
return MP_VAL;
}
/* init temps */
if ((err = mp_init_multi(&x, &y, &u, &v,
&A, &B, &C, &D, (void *)NULL)) != MP_OKAY) {
return err;
}
/* x = a, y = b */
if ((err = mp_mod(a, b, &x)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(b, &y)) != MP_OKAY) goto LBL_ERR;
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
if ((err = mp_sub(&C, b, &C)) != MP_OKAY) goto LBL_ERR;
}
/* C is now the inverse */
mp_exch(&C, c);
err = MP_OKAY;
LBL_ERR:
| | | 109 110 111 112 113 114 115 116 117 118 119 |
if ((err = mp_sub(&C, b, &C)) != MP_OKAY) goto LBL_ERR;
}
/* C is now the inverse */
mp_exch(&C, c);
err = MP_OKAY;
LBL_ERR:
mp_clear_multi(&x, &y, &u, &v, &A, &B, &C, &D, (void *)NULL);
return err;
}
#endif
|
Added libtommath/bn_s_mp_log.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 |
#include "tommath_private.h"
#ifdef BN_S_MP_LOG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
mp_err s_mp_log(const mp_int *a, mp_digit base, int *c)
{
mp_err err;
int high, low;
mp_int bracket_low, bracket_high, bracket_mid, t, bi_base;
mp_ord cmp = mp_cmp_d(a, base);
if ((cmp == MP_LT) || (cmp == MP_EQ)) {
*c = cmp == MP_EQ;
return MP_OKAY;
}
if ((err =
mp_init_multi(&bracket_low, &bracket_high,
&bracket_mid, &t, &bi_base, (void *)NULL)) != MP_OKAY) {
return err;
}
low = 0;
mp_set(&bracket_low, 1uL);
high = 1;
mp_set(&bracket_high, base);
/*
A kind of Giant-step/baby-step algorithm.
Idea shamelessly stolen from https://programmingpraxis.com/2010/05/07/integer-logarithms/2/
The effect is asymptotic, hence needs benchmarks to test if the Giant-step should be skipped
for small n.
*/
while (mp_cmp(&bracket_high, a) == MP_LT) {
low = high;
if ((err = mp_copy(&bracket_high, &bracket_low)) != MP_OKAY) {
goto LBL_END;
}
high <<= 1;
if ((err = mp_sqr(&bracket_high, &bracket_high)) != MP_OKAY) {
goto LBL_END;
}
}
mp_set(&bi_base, base);
while ((high - low) > 1) {
int mid = (high + low) >> 1;
if ((err = mp_expt_n(&bi_base, mid - low, &t)) != MP_OKAY) {
goto LBL_END;
}
if ((err = mp_mul(&bracket_low, &t, &bracket_mid)) != MP_OKAY) {
goto LBL_END;
}
cmp = mp_cmp(a, &bracket_mid);
if (cmp == MP_LT) {
high = mid;
mp_exch(&bracket_mid, &bracket_high);
}
if (cmp == MP_GT) {
low = mid;
mp_exch(&bracket_mid, &bracket_low);
}
if (cmp == MP_EQ) {
*c = mid;
goto LBL_END;
}
}
*c = (mp_cmp(&bracket_high, a) == MP_EQ) ? high : low;
LBL_END:
mp_clear_multi(&bracket_low, &bracket_high, &bracket_mid,
&t, &bi_base, (void *)NULL);
return err;
}
#endif
|
Added libtommath/bn_s_mp_log_2expt.c.
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 |
#include "tommath_private.h"
#ifdef BN_S_MP_LOG_2EXPT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
int s_mp_log_2expt(const mp_int *a, mp_digit base)
{
int y;
for (y = 0; (base & 1) == 0; y++, base >>= 1) {}
return (mp_count_bits(a) - 1) / y;
}
#endif
|
Added libtommath/bn_s_mp_log_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 |
#include "tommath_private.h"
#ifdef BN_S_MP_LOG_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
static mp_word s_pow(mp_word base, mp_word exponent)
{
mp_word result = 1u;
while (exponent != 0u) {
if ((exponent & 1u) == 1u) {
result *= base;
}
exponent >>= 1;
base *= base;
}
return result;
}
int s_mp_log_d(mp_digit base, mp_digit n)
{
mp_word bracket_low = 1uLL, bracket_high = base, N = n;
int ret, high = 1, low = 0;
if (n < base) {
return 0;
}
if (n == base) {
return 1;
}
while (bracket_high < N) {
low = high;
bracket_low = bracket_high;
high <<= 1;
bracket_high *= bracket_high;
}
while (((mp_digit)(high - low)) > 1uL) {
int mid = (low + high) >> 1;
mp_word bracket_mid = bracket_low * s_pow(base, (mp_word)(mid - low));
if (N < bracket_mid) {
high = mid ;
bracket_high = bracket_mid ;
}
if (N > bracket_mid) {
low = mid ;
bracket_low = bracket_mid ;
}
if (N == bracket_mid) {
return mid;
}
}
if (bracket_high == N) {
ret = high;
} else {
ret = low;
}
return ret;
}
#endif
|
Changes to libtommath/bn_s_mp_mul_high_digs_fast.c.
1 2 3 4 5 | #include "tommath_private.h" #ifdef BN_S_MP_MUL_HIGH_DIGS_FAST_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | #include "tommath_private.h" #ifdef BN_S_MP_MUL_HIGH_DIGS_FAST_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ /* this is a modified version of s_mp_mul_digs_fast that only produces * output digits *above* digs. See the comments for s_mp_mul_digs_fast * to see how it works. * * This is used in the Barrett reduction since for one of the multiplications * only the higher digits were needed. This essentially halves the work. * * Based on Algorithm 14.12 on pp.595 of HAC. |
| ︙ | ︙ |
Changes to libtommath/bn_s_mp_toom_mul.c.
| ︙ | ︙ | |||
142 143 144 145 146 147 148 | if ((err = mp_mul(&a2, &b2, &b1)) != MP_OKAY) goto LBL_ERR; /** \\S2 = (S2 - S3)/3; */ /** S2 = S2 - a1; */ if ((err = mp_sub(&S2, &a1, &S2)) != MP_OKAY) goto LBL_ERR; /** S2 = S2 / 3; \\ this is an exact division */ | | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 | if ((err = mp_mul(&a2, &b2, &b1)) != MP_OKAY) goto LBL_ERR; /** \\S2 = (S2 - S3)/3; */ /** S2 = S2 - a1; */ if ((err = mp_sub(&S2, &a1, &S2)) != MP_OKAY) goto LBL_ERR; /** S2 = S2 / 3; \\ this is an exact division */ if ((err = s_mp_div_3(&S2, &S2, NULL)) != MP_OKAY) goto LBL_ERR; /** a1 = S1 - a1; */ if ((err = mp_sub(&S1, &a1, &a1)) != MP_OKAY) goto LBL_ERR; /** a1 = a1 >> 1; */ if ((err = mp_div_2(&a1, &a1)) != MP_OKAY) goto LBL_ERR; |
| ︙ | ︙ |
Changes to libtommath/changes.txt.
1 2 3 4 5 6 7 |
Sep 04th, 2023
v1.2.1
-- Bugfix release because of potential integer overflow
c.f. PR #546 resp. CVE-2023-36328
Oct 22nd, 2019
v1.2.0
| > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
Mar 27th, 2024
v1.3.0
-- Deprecate more APIs which are replaced in develop (PR #572)
-- Add support for CMake (PR #573)
-- Add support for GitHub Actions (PR #573)
Sep 04th, 2023
v1.2.1
-- Bugfix release because of potential integer overflow
c.f. PR #546 resp. CVE-2023-36328
Oct 22nd, 2019
v1.2.0
|
| ︙ | ︙ |
Changes to libtommath/helper.pl.
| ︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 226 227 |
}
else {
die "patch_file failed: " . substr($v, 0, 30) . "..";
}
}
return $content;
}
sub process_makefiles {
my $write = shift;
my $changed_count = 0;
| > > > > > > > > > > > > > > > > > > > > > | | | > | > | 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 |
}
else {
die "patch_file failed: " . substr($v, 0, 30) . "..";
}
}
return $content;
}
sub make_sources_cmake {
my ($src_ref, $hdr_ref) = @_;
my @sources = @{ $src_ref };
my @headers = @{ $hdr_ref };
my $output = "# SPDX-License-Identifier: Unlicense
# Autogenerated File! Do not edit.
set(SOURCES\n";
foreach my $sobj (sort @sources) {
$output .= $sobj . "\n";
}
$output .= ")\n\nset(HEADERS\n";
foreach my $hobj (sort @headers) {
$output .= $hobj . "\n";
}
$output .= ")\n";
return $output;
}
sub process_makefiles {
my $write = shift;
my $changed_count = 0;
my @headers = bsd_glob("*.h");
my @sources = bsd_glob("*.c");
my @o = map { my $x = $_; $x =~ s/\.c$/.o/; $x } @sources;
my @all = sort(@sources, @headers);
my $var_o = prepare_variable("OBJECTS", @o);
(my $var_obj = $var_o) =~ s/\.o\b/.obj/sg;
# update MSVC project files
my $msvc_files = prepare_msvc_files_xml(\@all, qr/NOT_USED_HERE/, ['Debug|Win32', 'Release|Win32', 'Debug|x64', 'Release|x64']);
for my $m (qw/libtommath_VS2008.vcproj/) {
my $old = read_file($m);
my $new = $old;
$new =~ s|<Files>.*</Files>|$msvc_files|s;
if ($old ne $new) {
write_file($m, $new) if $write;
warn "changed: $m\n";
$changed_count++;
}
}
# update OBJECTS + HEADERS in makefile*
for my $m (qw/ makefile makefile.shared makefile_include.mk makefile.msvc makefile.unix makefile.mingw sources.cmake /) {
my $old = read_file($m);
my $new = $m eq 'makefile.msvc' ? patch_file($old, $var_obj)
: $m eq 'sources.cmake' ? make_sources_cmake(\@sources, \@headers)
: patch_file($old, $var_o);
if ($old ne $new) {
write_file($m, $new) if $write;
warn "changed: $m\n";
$changed_count++;
}
}
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
my $a = $&;
next if $a eq "mp_err";
$a =~ tr/[a-z]/[A-Z]/;
$a = 'BN_' . $a . '_C';
push @deps, $a;
}
}
@deps = sort(@deps);
foreach my $a (@deps) {
if ($list !~ /$a/) {
print {$class} "# define $a\n";
}
$list = $list . ',' . $a;
}
| > > > > > | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
my $a = $&;
next if $a eq "mp_err";
$a =~ tr/[a-z]/[A-Z]/;
$a = 'BN_' . $a . '_C';
push @deps, $a;
}
}
if ($filename =~ "BN_DEPRECATED") {
push(@deps, qw(BN_MP_GET_LL_C BN_MP_INIT_LL_C BN_MP_SET_LL_C));
push(@deps, qw(BN_MP_GET_MAG_ULL_C BN_MP_INIT_ULL_C BN_MP_SET_ULL_C));
push(@deps, qw(BN_MP_DIV_3_C BN_MP_EXPT_U32_C BN_MP_ROOT_U32_C BN_MP_LOG_U32_C));
}
@deps = sort(@deps);
foreach my $a (@deps) {
if ($list !~ /$a/) {
print {$class} "# define $a\n";
}
$list = $list . ',' . $a;
}
|
| ︙ | ︙ | |||
431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
sub generate_def {
my @files = split /\n/, `git ls-files`;
@files = grep(/\.c/, @files);
@files = map { my $x = $_; $x =~ s/^bn_|\.c$//g; $x; } @files;
@files = grep(!/mp_radix_smap/, @files);
push(@files, qw(mp_set_int mp_set_long mp_set_long_long mp_get_int mp_get_long mp_get_long_long mp_init_set_int));
my $files = join("\n ", sort(grep(/^mp_/, @files)));
write_file "tommath.def", "; libtommath
;
; Use this command to produce a 32-bit .lib file, for use in any MSVC version
; lib -machine:X86 -name:libtommath.dll -def:tommath.def -out:tommath.lib
; Use this command to produce a 64-bit .lib file, for use in any MSVC version
| > > | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
sub generate_def {
my @files = split /\n/, `git ls-files`;
@files = grep(/\.c/, @files);
@files = map { my $x = $_; $x =~ s/^bn_|\.c$//g; $x; } @files;
@files = grep(!/mp_radix_smap/, @files);
push(@files, qw(mp_set_int mp_set_long mp_set_long_long mp_get_int mp_get_long mp_get_long_long mp_init_set_int));
push(@files, qw(mp_get_ll mp_get_mag_ull mp_init_ll mp_set_ll mp_init_ull mp_set_ull));
push(@files, qw(mp_div_3 mp_expt_u32 mp_root_u32 mp_log_u32));
my $files = join("\n ", sort(grep(/^mp_/, @files)));
write_file "tommath.def", "; libtommath
;
; Use this command to produce a 32-bit .lib file, for use in any MSVC version
; lib -machine:X86 -name:libtommath.dll -def:tommath.def -out:tommath.lib
; Use this command to produce a 64-bit .lib file, for use in any MSVC version
|
| ︙ | ︙ |
Changes to libtommath/libtommath.pc.in.
|
| | | < | | | 1 2 3 4 5 6 7 8 9 |
prefix=@CMAKE_INSTALL_PREFIX@
libdir=${prefix}/@CMAKE_INSTALL_LIBDIR@
includedir=${prefix}/@CMAKE_INSTALL_INCLUDEDIR@
Name: LibTomMath
Description: public domain library for manipulating large integer numbers
Version: @PROJECT_VERSION@
Libs: -L${libdir} -ltommath
Cflags: -I${includedir}
|
Changes to libtommath/libtommath_VS2008.sln.
| ︙ | ︙ |
Changes to libtommath/libtommath_VS2008.vcproj.
| ︙ | ︙ | |||
395 396 397 398 399 400 401 | <File RelativePath="bn_mp_div_2.c" > </File> <File RelativePath="bn_mp_div_2d.c" > | < < < < | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 | <File RelativePath="bn_mp_div_2.c" > </File> <File RelativePath="bn_mp_div_2d.c" > </File> <File RelativePath="bn_mp_div_d.c" > </File> <File RelativePath="bn_mp_dr_is_modulus.c" |
| ︙ | ︙ | |||
425 426 427 428 429 430 431 | > </File> <File RelativePath="bn_mp_exch.c" > </File> <File | | | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | > </File> <File RelativePath="bn_mp_exch.c" > </File> <File RelativePath="bn_mp_expt_n.c" > </File> <File RelativePath="bn_mp_exptmod.c" > </File> <File |
| ︙ | ︙ | |||
471 472 473 474 475 476 477 | <File RelativePath="bn_mp_get_i64.c" > </File> <File RelativePath="bn_mp_get_l.c" > | < < < < < < < < | 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 | <File RelativePath="bn_mp_get_i64.c" > </File> <File RelativePath="bn_mp_get_l.c" > </File> <File RelativePath="bn_mp_get_mag_u32.c" > </File> <File RelativePath="bn_mp_get_mag_u64.c" > </File> <File RelativePath="bn_mp_get_mag_ul.c" > </File> <File RelativePath="bn_mp_grow.c" > </File> <File RelativePath="bn_mp_incr.c" |
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | <File RelativePath="bn_mp_init_i64.c" > </File> <File RelativePath="bn_mp_init_l.c" > | < < < < | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 | <File RelativePath="bn_mp_init_i64.c" > </File> <File RelativePath="bn_mp_init_l.c" > </File> <File RelativePath="bn_mp_init_multi.c" > </File> <File RelativePath="bn_mp_init_set.c" |
| ︙ | ︙ | |||
547 548 549 550 551 552 553 | <File RelativePath="bn_mp_init_u64.c" > </File> <File RelativePath="bn_mp_init_ul.c" > | < < < < | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 | <File RelativePath="bn_mp_init_u64.c" > </File> <File RelativePath="bn_mp_init_ul.c" > </File> <File RelativePath="bn_mp_invmod.c" > </File> <File RelativePath="bn_mp_is_square.c" |
| ︙ | ︙ | |||
577 578 579 580 581 582 583 | > </File> <File RelativePath="bn_mp_lcm.c" > </File> <File | | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 | > </File> <File RelativePath="bn_mp_lcm.c" > </File> <File RelativePath="bn_mp_log_n.c" > </File> <File RelativePath="bn_mp_lshd.c" > </File> <File |
| ︙ | ︙ | |||
725 726 727 728 729 730 731 | > </File> <File RelativePath="bn_mp_reduce_setup.c" > </File> <File | | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 | > </File> <File RelativePath="bn_mp_reduce_setup.c" > </File> <File RelativePath="bn_mp_root_n.c" > </File> <File RelativePath="bn_mp_rshd.c" > </File> <File |
| ︙ | ︙ | |||
755 756 757 758 759 760 761 | <File RelativePath="bn_mp_set_i64.c" > </File> <File RelativePath="bn_mp_set_l.c" > | < < < < < < < < | 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 | <File RelativePath="bn_mp_set_i64.c" > </File> <File RelativePath="bn_mp_set_l.c" > </File> <File RelativePath="bn_mp_set_u32.c" > </File> <File RelativePath="bn_mp_set_u64.c" > </File> <File RelativePath="bn_mp_set_ul.c" > </File> <File RelativePath="bn_mp_shrink.c" > </File> <File RelativePath="bn_mp_signed_rsh.c" |
| ︙ | ︙ | |||
851 852 853 854 855 856 857 858 859 860 861 862 863 864 | <File RelativePath="bn_s_mp_add.c" > </File> <File RelativePath="bn_s_mp_balance_mul.c" > </File> <File RelativePath="bn_s_mp_exptmod.c" > </File> <File RelativePath="bn_s_mp_exptmod_fast.c" | > > > > | 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | <File RelativePath="bn_s_mp_add.c" > </File> <File RelativePath="bn_s_mp_balance_mul.c" > </File> <File RelativePath="bn_s_mp_div_3.c" > </File> <File RelativePath="bn_s_mp_exptmod.c" > </File> <File RelativePath="bn_s_mp_exptmod_fast.c" |
| ︙ | ︙ | |||
879 880 881 882 883 884 885 886 887 888 889 890 891 892 | <File RelativePath="bn_s_mp_karatsuba_mul.c" > </File> <File RelativePath="bn_s_mp_karatsuba_sqr.c" > </File> <File RelativePath="bn_s_mp_montgomery_reduce_fast.c" > </File> <File RelativePath="bn_s_mp_mul_digs.c" | > > > > > > > > > > > > | 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 | <File RelativePath="bn_s_mp_karatsuba_mul.c" > </File> <File RelativePath="bn_s_mp_karatsuba_sqr.c" > </File> <File RelativePath="bn_s_mp_log.c" > </File> <File RelativePath="bn_s_mp_log_2expt.c" > </File> <File RelativePath="bn_s_mp_log_d.c" > </File> <File RelativePath="bn_s_mp_montgomery_reduce_fast.c" > </File> <File RelativePath="bn_s_mp_mul_digs.c" |
| ︙ | ︙ |
Changes to libtommath/makefile.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | LCOV_ARGS=--directory . #START_INS OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ | | | | | | < | | | | | | | | | | | | | | | > | | | | | 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 | LCOV_ARGS=--directory . #START_INS OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \ bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \ bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \ bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \ bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \ bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \ bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \ bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \ bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \ bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \ bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \ bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \ bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \ bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \ bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \ bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \ bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \ bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \ bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o #END_INS $(LIBNAME): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ |
| ︙ | ︙ | |||
129 130 131 132 133 134 135 | .PHONY: pre_gen pre_gen: mkdir -p pre_gen perl gen.pl sed -e 's/[[:blank:]]*$$//' mpi.c > pre_gen/mpi.c rm mpi.c | > > > > | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | .PHONY: pre_gen pre_gen: mkdir -p pre_gen perl gen.pl sed -e 's/[[:blank:]]*$$//' mpi.c > pre_gen/mpi.c rm mpi.c zipup: $(MAKE) clean $(MAKE) .zipup .zipup: astyle new_file docs @# Update the index, so diff-index won't fail in case the pdf has been created. @# As the pdf creation modifies the tex files, git sometimes detects the @# modified files, but misses that it's put back to its original version. @git update-index --refresh @git diff-index --quiet HEAD -- || ( echo "FAILURE: uncommited changes or not a git" && exit 1 ) rm -rf libtommath-$(VERSION) ltm-$(VERSION).* @# files/dirs excluded from "git archive" are defined in .gitattributes |
| ︙ | ︙ |
Changes to libtommath/makefile.mingw.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # MAKEFILE for MS Windows (mingw + gcc + gmake) # # BEWARE: variable OBJECTS is updated via helper.pl ### USAGE: # Open a command prompt with gcc + gmake in PATH and start: # # gmake -f makefile.mingw all # test.exe # gmake -f makefile.mingw PREFIX=c:\devel\libtom install #The following can be overridden from command line e.g. make -f makefile.mingw CC=gcc ARFLAGS=rcs PREFIX = c:\mingw | | > > | > > | | | | | | < | | | | | | | | | | | | | | | > | | | | | | 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 | # MAKEFILE for MS Windows (mingw + gcc + gmake) # # BEWARE: variable OBJECTS is updated via helper.pl ### USAGE: # Open a command prompt with gcc + gmake in PATH and start: # # gmake -f makefile.mingw all # test.exe # gmake -f makefile.mingw PREFIX=c:\devel\libtom install #The following can be overridden from command line e.g. make -f makefile.mingw CC=gcc ARFLAGS=rcs PREFIX = c:\mingw CC = i686-w64-mingw32-gcc #CC = x86_64-w64-mingw32-clang #CC = aarch64-w64-mingw32-clang AR = ar ARFLAGS = r RANLIB = ranlib STRIP = i686-w64-mingw32-gcc-strip #STRIP = x86_64-w64-mingw32-strip #STRIP = aarch64-w64-mingw32-strip CFLAGS = -O2 LDFLAGS = #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) -DTCL_WITH_EXTERNAL_TOMMATH LTM_LDFLAGS = $(LDFLAGS) -static-libgcc #Libraries to be created LIBMAIN_S =libtommath.a LIBMAIN_I =libtommath.dll.a LIBMAIN_D =libtommath.dll #List of objects to compile (all goes to libtommath.a) OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \ bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \ bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \ bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \ bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \ bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \ bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \ bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \ bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \ bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \ bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \ bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \ bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \ bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \ bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \ bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \ bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \ bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \ bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o HEADERS_PUB=tommath.h HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) #Dependencies on *.h $(OBJECTS): $(HEADERS) .c.o: $(CC) $(LTM_CFLAGS) -c $< -o $@ #Create libtommath.a $(LIBMAIN_S): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ #Create DLL + import library libtommath.dll.a $(LIBMAIN_D) $(LIBMAIN_I): $(OBJECTS) $(CC) -s -shared -o $(LIBMAIN_D) $^ -Wl,--enable-auto-import tommath.def -Wl,--out-implib=$(LIBMAIN_I) $(LTM_LDFLAGS) $(STRIP) -S $(LIBMAIN_D) #Build test suite test.exe: demo/shared.o demo/test.o $(LIBMAIN_S) $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) $^ -o $@ @echo NOTICE: start the tests by launching test.exe |
| ︙ | ︙ |
Changes to libtommath/makefile.msvc.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | #Libraries to be created (this makefile builds only static libraries) LIBMAIN_S =tommath.lib #List of objects to compile (all goes to tommath.lib) OBJECTS=bn_cutoffs.obj bn_deprecated.obj bn_mp_2expt.obj bn_mp_abs.obj bn_mp_add.obj bn_mp_add_d.obj bn_mp_addmod.obj \ bn_mp_and.obj bn_mp_clamp.obj bn_mp_clear.obj bn_mp_clear_multi.obj bn_mp_cmp.obj bn_mp_cmp_d.obj bn_mp_cmp_mag.obj \ bn_mp_cnt_lsb.obj bn_mp_complement.obj bn_mp_copy.obj bn_mp_count_bits.obj bn_mp_decr.obj bn_mp_div.obj bn_mp_div_2.obj \ | | | | | | < | | | | | | > | | | | < | | | | > | | | | | 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 | #Libraries to be created (this makefile builds only static libraries) LIBMAIN_S =tommath.lib #List of objects to compile (all goes to tommath.lib) OBJECTS=bn_cutoffs.obj bn_deprecated.obj bn_mp_2expt.obj bn_mp_abs.obj bn_mp_add.obj bn_mp_add_d.obj bn_mp_addmod.obj \ bn_mp_and.obj bn_mp_clamp.obj bn_mp_clear.obj bn_mp_clear_multi.obj bn_mp_cmp.obj bn_mp_cmp_d.obj bn_mp_cmp_mag.obj \ bn_mp_cnt_lsb.obj bn_mp_complement.obj bn_mp_copy.obj bn_mp_count_bits.obj bn_mp_decr.obj bn_mp_div.obj bn_mp_div_2.obj \ bn_mp_div_2d.obj bn_mp_div_d.obj bn_mp_dr_is_modulus.obj bn_mp_dr_reduce.obj bn_mp_dr_setup.obj \ bn_mp_error_to_string.obj bn_mp_exch.obj bn_mp_expt_n.obj bn_mp_exptmod.obj bn_mp_exteuclid.obj bn_mp_fread.obj \ bn_mp_from_sbin.obj bn_mp_from_ubin.obj bn_mp_fwrite.obj bn_mp_gcd.obj bn_mp_get_double.obj bn_mp_get_i32.obj \ bn_mp_get_i64.obj bn_mp_get_l.obj bn_mp_get_mag_u32.obj bn_mp_get_mag_u64.obj bn_mp_get_mag_ul.obj bn_mp_grow.obj \ bn_mp_incr.obj bn_mp_init.obj bn_mp_init_copy.obj bn_mp_init_i32.obj bn_mp_init_i64.obj bn_mp_init_l.obj \ bn_mp_init_multi.obj bn_mp_init_set.obj bn_mp_init_size.obj bn_mp_init_u32.obj bn_mp_init_u64.obj bn_mp_init_ul.obj \ bn_mp_invmod.obj bn_mp_is_square.obj bn_mp_iseven.obj bn_mp_isodd.obj bn_mp_kronecker.obj bn_mp_lcm.obj bn_mp_log_n.obj \ bn_mp_lshd.obj bn_mp_mod.obj bn_mp_mod_2d.obj bn_mp_mod_d.obj bn_mp_montgomery_calc_normalization.obj \ bn_mp_montgomery_reduce.obj bn_mp_montgomery_setup.obj bn_mp_mul.obj bn_mp_mul_2.obj bn_mp_mul_2d.obj bn_mp_mul_d.obj \ bn_mp_mulmod.obj bn_mp_neg.obj bn_mp_or.obj bn_mp_pack.obj bn_mp_pack_count.obj bn_mp_prime_fermat.obj \ bn_mp_prime_frobenius_underwood.obj bn_mp_prime_is_prime.obj bn_mp_prime_miller_rabin.obj \ bn_mp_prime_next_prime.obj bn_mp_prime_rabin_miller_trials.obj bn_mp_prime_rand.obj \ bn_mp_prime_strong_lucas_selfridge.obj bn_mp_radix_size.obj bn_mp_radix_smap.obj bn_mp_rand.obj \ bn_mp_read_radix.obj bn_mp_reduce.obj bn_mp_reduce_2k.obj bn_mp_reduce_2k_l.obj bn_mp_reduce_2k_setup.obj \ bn_mp_reduce_2k_setup_l.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_setup.obj \ bn_mp_root_n.obj bn_mp_rshd.obj bn_mp_sbin_size.obj bn_mp_set.obj bn_mp_set_double.obj bn_mp_set_i32.obj \ bn_mp_set_i64.obj bn_mp_set_l.obj bn_mp_set_u32.obj bn_mp_set_u64.obj bn_mp_set_ul.obj bn_mp_shrink.obj \ bn_mp_signed_rsh.obj bn_mp_sqr.obj bn_mp_sqrmod.obj bn_mp_sqrt.obj bn_mp_sqrtmod_prime.obj bn_mp_sub.obj bn_mp_sub_d.obj \ bn_mp_submod.obj bn_mp_to_radix.obj bn_mp_to_sbin.obj bn_mp_to_ubin.obj bn_mp_ubin_size.obj bn_mp_unpack.obj \ bn_mp_xor.obj bn_mp_zero.obj bn_prime_tab.obj bn_s_mp_add.obj bn_s_mp_balance_mul.obj bn_s_mp_div_3.obj \ bn_s_mp_exptmod.obj bn_s_mp_exptmod_fast.obj bn_s_mp_get_bit.obj bn_s_mp_invmod_fast.obj bn_s_mp_invmod_slow.obj \ bn_s_mp_karatsuba_mul.obj bn_s_mp_karatsuba_sqr.obj bn_s_mp_log.obj bn_s_mp_log_2expt.obj bn_s_mp_log_d.obj \ bn_s_mp_montgomery_reduce_fast.obj bn_s_mp_mul_digs.obj bn_s_mp_mul_digs_fast.obj bn_s_mp_mul_high_digs.obj \ bn_s_mp_mul_high_digs_fast.obj bn_s_mp_prime_is_divisible.obj bn_s_mp_rand_jenkins.obj \ bn_s_mp_rand_platform.obj bn_s_mp_reverse.obj bn_s_mp_sqr.obj bn_s_mp_sqr_fast.obj bn_s_mp_sub.obj \ bn_s_mp_toom_mul.obj bn_s_mp_toom_sqr.obj HEADERS_PUB=tommath.h HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the tommath.lib library (static) default: $(LIBMAIN_S) |
| ︙ | ︙ |
Changes to libtommath/makefile.shared.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | LCOV_ARGS=--directory .libs --directory . #START_INS OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ | | | | | | < | | | | | | | | | | | | | | | > | | | | | > | 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 | LCOV_ARGS=--directory .libs --directory . #START_INS OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \ bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \ bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \ bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \ bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \ bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \ bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \ bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \ bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \ bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \ bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \ bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \ bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \ bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \ bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \ bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \ bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \ bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \ bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o #END_INS objs: $(OBJECTS) .c.o: $(HEADERS) $(LTCOMPILE) $(LTM_CFLAGS) $(LTM_LDFLAGS) -o $@ -c $< LOBJECTS = $(OBJECTS:.o=.lo) $(LIBNAME): $(OBJECTS) $(LTLINK) $(LTM_LDFLAGS) $(LOBJECTS) -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION_SO) $(LTM_LIBTOOLFLAGS) install: $(LIBNAME) install -d $(DESTDIR)$(LIBPATH) install -d $(DESTDIR)$(INCPATH) $(LIBTOOL) --mode=install install -m 644 $(LIBNAME) $(DESTDIR)$(LIBPATH)/$(LIBNAME) install -m 644 $(HEADERS_PUB) $(DESTDIR)$(INCPATH) sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION_PC),' -e 's,@CMAKE_INSTALL_LIBDIR@,lib,' \ -e 's,@CMAKE_INSTALL_INCLUDEDIR@,include,' libtommath.pc.in > libtommath.pc install -d $(DESTDIR)$(LIBPATH)/pkgconfig install -m 644 libtommath.pc $(DESTDIR)$(LIBPATH)/pkgconfig/ uninstall: $(LIBTOOL) --mode=uninstall rm $(DESTDIR)$(LIBPATH)/$(LIBNAME) rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%) rm $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc |
| ︙ | ︙ |
Changes to libtommath/makefile.unix.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | CC = cc AR = ar ARFLAGS = r RANLIB = ranlib CFLAGS = -O2 LDFLAGS = | | | | | | | < | | | | | | | | | | | | | | | > | | | | | 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 | CC = cc AR = ar ARFLAGS = r RANLIB = ranlib CFLAGS = -O2 LDFLAGS = VERSION = 1.3.0 #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) LTM_LDFLAGS = $(LDFLAGS) #Library to be created (this makefile builds only static library) LIBMAIN_S = libtommath.a OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \ bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \ bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \ bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \ bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \ bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \ bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \ bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \ bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \ bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \ bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \ bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \ bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \ bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \ bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \ bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \ bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \ bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \ bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o HEADERS_PUB=tommath.h HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) |
| ︙ | ︙ |
Changes to libtommath/makefile_include.mk.
1 2 3 4 5 | # # Include makefile for libtommath # #version of library | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
#
# Include makefile for libtommath
#
#version of library
VERSION=1.3.0
VERSION_PC=1.3.0
VERSION_SO=4:0:3
PLATFORM := $(shell uname | sed -e 's/_.*//')
# default make target
default: ${LIBNAME}
# Compiler and Linker Names
|
| ︙ | ︙ |
Added libtommath/sources.cmake.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # SPDX-License-Identifier: Unlicense # Autogenerated File! Do not edit. set(SOURCES bn_cutoffs.c bn_deprecated.c bn_mp_2expt.c bn_mp_abs.c bn_mp_add.c bn_mp_add_d.c bn_mp_addmod.c bn_mp_and.c bn_mp_clamp.c bn_mp_clear.c bn_mp_clear_multi.c bn_mp_cmp.c bn_mp_cmp_d.c bn_mp_cmp_mag.c bn_mp_cnt_lsb.c bn_mp_complement.c bn_mp_copy.c bn_mp_count_bits.c bn_mp_decr.c bn_mp_div.c bn_mp_div_2.c bn_mp_div_2d.c bn_mp_div_d.c bn_mp_dr_is_modulus.c bn_mp_dr_reduce.c bn_mp_dr_setup.c bn_mp_error_to_string.c bn_mp_exch.c bn_mp_expt_n.c bn_mp_exptmod.c bn_mp_exteuclid.c bn_mp_fread.c bn_mp_from_sbin.c bn_mp_from_ubin.c bn_mp_fwrite.c bn_mp_gcd.c bn_mp_get_double.c bn_mp_get_i32.c bn_mp_get_i64.c bn_mp_get_l.c bn_mp_get_mag_u32.c bn_mp_get_mag_u64.c bn_mp_get_mag_ul.c bn_mp_grow.c bn_mp_incr.c bn_mp_init.c bn_mp_init_copy.c bn_mp_init_i32.c bn_mp_init_i64.c bn_mp_init_l.c bn_mp_init_multi.c bn_mp_init_set.c bn_mp_init_size.c bn_mp_init_u32.c bn_mp_init_u64.c bn_mp_init_ul.c bn_mp_invmod.c bn_mp_is_square.c bn_mp_iseven.c bn_mp_isodd.c bn_mp_kronecker.c bn_mp_lcm.c bn_mp_log_n.c bn_mp_lshd.c bn_mp_mod.c bn_mp_mod_2d.c bn_mp_mod_d.c bn_mp_montgomery_calc_normalization.c bn_mp_montgomery_reduce.c bn_mp_montgomery_setup.c bn_mp_mul.c bn_mp_mul_2.c bn_mp_mul_2d.c bn_mp_mul_d.c bn_mp_mulmod.c bn_mp_neg.c bn_mp_or.c bn_mp_pack.c bn_mp_pack_count.c bn_mp_prime_fermat.c bn_mp_prime_frobenius_underwood.c bn_mp_prime_is_prime.c bn_mp_prime_miller_rabin.c bn_mp_prime_next_prime.c bn_mp_prime_rabin_miller_trials.c bn_mp_prime_rand.c bn_mp_prime_strong_lucas_selfridge.c bn_mp_radix_size.c bn_mp_radix_smap.c bn_mp_rand.c bn_mp_read_radix.c bn_mp_reduce.c bn_mp_reduce_2k.c bn_mp_reduce_2k_l.c bn_mp_reduce_2k_setup.c bn_mp_reduce_2k_setup_l.c bn_mp_reduce_is_2k.c bn_mp_reduce_is_2k_l.c bn_mp_reduce_setup.c bn_mp_root_n.c bn_mp_rshd.c bn_mp_sbin_size.c bn_mp_set.c bn_mp_set_double.c bn_mp_set_i32.c bn_mp_set_i64.c bn_mp_set_l.c bn_mp_set_u32.c bn_mp_set_u64.c bn_mp_set_ul.c bn_mp_shrink.c bn_mp_signed_rsh.c bn_mp_sqr.c bn_mp_sqrmod.c bn_mp_sqrt.c bn_mp_sqrtmod_prime.c bn_mp_sub.c bn_mp_sub_d.c bn_mp_submod.c bn_mp_to_radix.c bn_mp_to_sbin.c bn_mp_to_ubin.c bn_mp_ubin_size.c bn_mp_unpack.c bn_mp_xor.c bn_mp_zero.c bn_prime_tab.c bn_s_mp_add.c bn_s_mp_balance_mul.c bn_s_mp_div_3.c bn_s_mp_exptmod.c bn_s_mp_exptmod_fast.c bn_s_mp_get_bit.c bn_s_mp_invmod_fast.c bn_s_mp_invmod_slow.c bn_s_mp_karatsuba_mul.c bn_s_mp_karatsuba_sqr.c bn_s_mp_log.c bn_s_mp_log_2expt.c bn_s_mp_log_d.c bn_s_mp_montgomery_reduce_fast.c bn_s_mp_mul_digs.c bn_s_mp_mul_digs_fast.c bn_s_mp_mul_high_digs.c bn_s_mp_mul_high_digs_fast.c bn_s_mp_prime_is_divisible.c bn_s_mp_rand_jenkins.c bn_s_mp_rand_platform.c bn_s_mp_reverse.c bn_s_mp_sqr.c bn_s_mp_sqr_fast.c bn_s_mp_sub.c bn_s_mp_toom_mul.c bn_s_mp_toom_sqr.c ) set(HEADERS tommath.h tommath_class.h tommath_cutoffs.h tommath_private.h tommath_superclass.h ) |
Changes to libtommath/tommath.def.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
mp_div_3
mp_div_d
mp_dr_is_modulus
mp_dr_reduce
mp_dr_setup
mp_error_to_string
mp_exch
mp_expt_u32
mp_exptmod
mp_exteuclid
mp_fread
mp_from_sbin
mp_from_ubin
mp_fwrite
| > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
mp_div_3
mp_div_d
mp_dr_is_modulus
mp_dr_reduce
mp_dr_setup
mp_error_to_string
mp_exch
mp_expt_n
mp_expt_u32
mp_exptmod
mp_exteuclid
mp_fread
mp_from_sbin
mp_from_ubin
mp_fwrite
|
| ︙ | ︙ | |||
71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
mp_init_ull
mp_invmod
mp_is_square
mp_iseven
mp_isodd
mp_kronecker
mp_lcm
mp_log_u32
mp_lshd
mp_mod
mp_mod_2d
mp_mod_d
mp_montgomery_calc_normalization
mp_montgomery_reduce
| > | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
mp_init_ull
mp_invmod
mp_is_square
mp_iseven
mp_isodd
mp_kronecker
mp_lcm
mp_log_n
mp_log_u32
mp_lshd
mp_mod
mp_mod_2d
mp_mod_d
mp_montgomery_calc_normalization
mp_montgomery_reduce
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
mp_reduce_2k
mp_reduce_2k_l
mp_reduce_2k_setup
mp_reduce_2k_setup_l
mp_reduce_is_2k
mp_reduce_is_2k_l
mp_reduce_setup
mp_root_u32
mp_rshd
mp_sbin_size
mp_set
mp_set_double
mp_set_i32
mp_set_i64
| > | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
mp_reduce_2k
mp_reduce_2k_l
mp_reduce_2k_setup
mp_reduce_2k_setup_l
mp_reduce_is_2k
mp_reduce_is_2k_l
mp_reduce_setup
mp_root_n
mp_root_u32
mp_rshd
mp_sbin_size
mp_set
mp_set_double
mp_set_i32
mp_set_i64
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 |
mp_to_radix
mp_to_sbin
mp_to_ubin
mp_ubin_size
mp_unpack
mp_xor
mp_zero
| | | | > | > | | | < | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
mp_to_radix
mp_to_sbin
mp_to_ubin
mp_ubin_size
mp_unpack
mp_xor
mp_zero
s_mp_add
s_mp_balance_mul
s_mp_karatsuba_mul
s_mp_karatsuba_sqr
s_mp_mul_digs
s_mp_mul_digs_fast
s_mp_reverse
s_mp_sqr
s_mp_sqr_fast
s_mp_sub
s_mp_toom_mul
s_mp_toom_sqr
|
Changes to libtommath/tommath.h.
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
# else
# define MP_WUR
# endif
#endif
#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405)
# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
| < < < < < < < < > | < < | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
# else
# define MP_WUR
# endif
#endif
#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405)
# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
#elif defined(_MSC_VER) && _MSC_VER >= 1500
# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
#else
# define MP_DEPRECATED(s)
# define MP_DEPRECATED_PRAGMA(s)
#endif
#define DIGIT_BIT (MP_DEPRECATED_PRAGMA("DIGIT_BIT macro is deprecated, MP_DIGIT_BIT instead") MP_DIGIT_BIT)
#define USED(m) (MP_DEPRECATED_PRAGMA("USED macro is deprecated, use z->used instead") (m)->used)
#define DIGIT(m, k) (MP_DEPRECATED_PRAGMA("DIGIT macro is deprecated, use z->dp instead") (m)->dp[(k)])
#define SIGN(m) (MP_DEPRECATED_PRAGMA("SIGN macro is deprecated, use z->sign instead") (m)->sign)
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 | void mp_set_u64(mp_int *a, uint64_t b); mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR; /* get magnitude */ uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR; uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR; unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR; | | | | | | | | | | 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 |
void mp_set_u64(mp_int *a, uint64_t b);
mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR;
/* get magnitude */
uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR;
uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR;
unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_get_mag_u64) unsigned long long mp_get_mag_ull(const mp_int *a) MP_WUR;
/* get integer, set integer (long) */
long mp_get_l(const mp_int *a) MP_WUR;
void mp_set_l(mp_int *a, long b);
mp_err mp_init_l(mp_int *a, long b) MP_WUR;
/* get integer, set integer (unsigned long) */
#define mp_get_ul(a) ((unsigned long)mp_get_l(a))
void mp_set_ul(mp_int *a, unsigned long b);
mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR;
/* get integer, set integer (long long) */
MP_DEPRECATED(mp_get_i64) long long mp_get_ll(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_set_i64) void mp_set_ll(mp_int *a, long long b);
MP_DEPRECATED(mp_init_i64) mp_err mp_init_ll(mp_int *a, long long b) MP_WUR;
/* get integer, set integer (unsigned long long) */
#define mp_get_ull(a) (MP_DEPRECATED_PRAGMA("mp_get_ull() has been deprecated, use mp_get_u64()") ((unsigned long long)mp_get_ll(a)))
MP_DEPRECATED(mp_set_u64) void mp_set_ull(mp_int *a, unsigned long long b);
MP_DEPRECATED(mp_init_u64) mp_err mp_init_ull(mp_int *a, unsigned long long b) MP_WUR;
/* set to single unsigned digit, up to MP_DIGIT_MAX */
void mp_set(mp_int *a, mp_digit b);
mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR;
/* get integer, set integer and init with integer (deprecated) */
MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_get_mag_u64/mp_get_u64) unsigned long long mp_get_long_long(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b);
MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b);
MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, unsigned long long b);
MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
/* copy, b = a */
mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR;
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 | /* c = a / 2**b, implemented as c = a >> b */ mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR; /* b = a/2 */ mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR; /* a/3 => 3c + d == a */ | | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | /* c = a / 2**b, implemented as c = a >> b */ mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR; /* b = a/2 */ mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR; /* a/3 => 3c + d == a */ MP_DEPRECATED(mp_div_d) mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR; /* c = a * 2**b, implemented as c = a << b */ mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR; /* b = a*2 */ mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR; |
| ︙ | ︙ | |||
559 560 561 562 563 564 565 566 567 568 569 | /* produces value such that U1*a + U2*b = U3 */ mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR; /* c = [a, b] or (a*b)/(a, b) */ mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* finds one of the b'th root of a, such that |c|**b <= |a| * * returns error if a < 0 and b is even */ | > > > > > > > > > > > | | | | 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 | /* produces value such that U1*a + U2*b = U3 */ mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR; /* c = [a, b] or (a*b)/(a, b) */ mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* Integer logarithm to integer base */ mp_err mp_log_n(const mp_int *a, int base, int *c) MP_WUR; MP_DEPRECATED(mp_log_n) mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c) MP_WUR; /* c = a**b */ mp_err mp_expt_n(const mp_int *a, int b, mp_int *c) MP_WUR; MP_DEPRECATED(mp_expt_n) mp_err mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR; MP_DEPRECATED(mp_expt_n) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; MP_DEPRECATED(mp_expt_n) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR; /* finds one of the b'th root of a, such that |c|**b <= |a| * * returns error if a < 0 and b is even */ mp_err mp_root_n(const mp_int *a, int b, mp_int *c) MP_WUR; MP_DEPRECATED(mp_root_n) mp_err mp_root_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR; MP_DEPRECATED(mp_root_n) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; MP_DEPRECATED(mp_root_n) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR; /* special sqrt algo */ mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR; /* special sqrt (mod prime) */ mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR; |
| ︙ | ︙ | |||
725 726 727 728 729 730 731 |
* so it can be NULL
*
*/
MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
private_mp_prime_callback cb, void *dat) MP_WUR;
mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
| < < < < < < < < | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 |
* so it can be NULL
*
*/
MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
private_mp_prime_callback cb, void *dat) MP_WUR;
mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
/* ---> radix conversion <--- */
int mp_count_bits(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR;
|
| ︙ | ︙ |
Changes to libtommath/tommath_class.h.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | # define BN_MP_COMPLEMENT_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DECR_C # define BN_MP_DIV_C # define BN_MP_DIV_2_C # define BN_MP_DIV_2D_C | < | < < < < | | 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 | # define BN_MP_COMPLEMENT_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DECR_C # define BN_MP_DIV_C # define BN_MP_DIV_2_C # define BN_MP_DIV_2D_C # define BN_MP_DIV_D_C # define BN_MP_DR_IS_MODULUS_C # define BN_MP_DR_REDUCE_C # define BN_MP_DR_SETUP_C # define BN_MP_ERROR_TO_STRING_C # define BN_MP_EXCH_C # define BN_MP_EXPT_N_C # define BN_MP_EXPTMOD_C # define BN_MP_EXTEUCLID_C # define BN_MP_FREAD_C # define BN_MP_FROM_SBIN_C # define BN_MP_FROM_UBIN_C # define BN_MP_FWRITE_C # define BN_MP_GCD_C # define BN_MP_GET_DOUBLE_C # define BN_MP_GET_I32_C # define BN_MP_GET_I64_C # define BN_MP_GET_L_C # define BN_MP_GET_MAG_U32_C # define BN_MP_GET_MAG_U64_C # define BN_MP_GET_MAG_UL_C # define BN_MP_GROW_C # define BN_MP_INCR_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_INIT_I32_C # define BN_MP_INIT_I64_C # define BN_MP_INIT_L_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SET_C # define BN_MP_INIT_SIZE_C # define BN_MP_INIT_U32_C # define BN_MP_INIT_U64_C # define BN_MP_INIT_UL_C # define BN_MP_INVMOD_C # define BN_MP_IS_SQUARE_C # define BN_MP_ISEVEN_C # define BN_MP_ISODD_C # define BN_MP_KRONECKER_C # define BN_MP_LCM_C # define BN_MP_LOG_N_C # define BN_MP_LSHD_C # define BN_MP_MOD_C # define BN_MP_MOD_2D_C # define BN_MP_MOD_D_C # define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C # define BN_MP_MONTGOMERY_REDUCE_C # define BN_MP_MONTGOMERY_SETUP_C |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 | # define BN_MP_REDUCE_2K_C # define BN_MP_REDUCE_2K_L_C # define BN_MP_REDUCE_2K_SETUP_C # define BN_MP_REDUCE_2K_SETUP_L_C # define BN_MP_REDUCE_IS_2K_C # define BN_MP_REDUCE_IS_2K_L_C # define BN_MP_REDUCE_SETUP_C | | < < > > > > | 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 | # define BN_MP_REDUCE_2K_C # define BN_MP_REDUCE_2K_L_C # define BN_MP_REDUCE_2K_SETUP_C # define BN_MP_REDUCE_2K_SETUP_L_C # define BN_MP_REDUCE_IS_2K_C # define BN_MP_REDUCE_IS_2K_L_C # define BN_MP_REDUCE_SETUP_C # define BN_MP_ROOT_N_C # define BN_MP_RSHD_C # define BN_MP_SBIN_SIZE_C # define BN_MP_SET_C # define BN_MP_SET_DOUBLE_C # define BN_MP_SET_I32_C # define BN_MP_SET_I64_C # define BN_MP_SET_L_C # define BN_MP_SET_U32_C # define BN_MP_SET_U64_C # define BN_MP_SET_UL_C # define BN_MP_SHRINK_C # define BN_MP_SIGNED_RSH_C # define BN_MP_SQR_C # define BN_MP_SQRMOD_C # define BN_MP_SQRT_C # define BN_MP_SQRTMOD_PRIME_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C # define BN_MP_SUBMOD_C # define BN_MP_TO_RADIX_C # define BN_MP_TO_SBIN_C # define BN_MP_TO_UBIN_C # define BN_MP_UBIN_SIZE_C # define BN_MP_UNPACK_C # define BN_MP_XOR_C # define BN_MP_ZERO_C # define BN_PRIME_TAB_C # define BN_S_MP_ADD_C # define BN_S_MP_BALANCE_MUL_C # define BN_S_MP_DIV_3_C # define BN_S_MP_EXPTMOD_C # define BN_S_MP_EXPTMOD_FAST_C # define BN_S_MP_GET_BIT_C # define BN_S_MP_INVMOD_FAST_C # define BN_S_MP_INVMOD_SLOW_C # define BN_S_MP_KARATSUBA_MUL_C # define BN_S_MP_KARATSUBA_SQR_C # define BN_S_MP_LOG_C # define BN_S_MP_LOG_2EXPT_C # define BN_S_MP_LOG_D_C # define BN_S_MP_MONTGOMERY_REDUCE_FAST_C # define BN_S_MP_MUL_DIGS_C # define BN_S_MP_MUL_DIGS_FAST_C # define BN_S_MP_MUL_HIGH_DIGS_C # define BN_S_MP_MUL_HIGH_DIGS_FAST_C # define BN_S_MP_PRIME_IS_DIVISIBLE_C # define BN_S_MP_RAND_JENKINS_C |
| ︙ | ︙ | |||
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 | # define BN_FAST_MP_MONTGOMERY_REDUCE_C # define BN_FAST_S_MP_MUL_DIGS_C # define BN_FAST_S_MP_MUL_HIGH_DIGS_C # define BN_FAST_S_MP_SQR_C # define BN_MP_AND_C # define BN_MP_BALANCE_MUL_C # define BN_MP_CMP_D_C # define BN_MP_EXPORT_C # define BN_MP_EXPTMOD_FAST_C # define BN_MP_EXPT_D_C # define BN_MP_EXPT_D_EX_C # define BN_MP_EXPT_U32_C # define BN_MP_FROM_SBIN_C # define BN_MP_FROM_UBIN_C # define BN_MP_GET_BIT_C # define BN_MP_GET_INT_C # define BN_MP_GET_LONG_C # define BN_MP_GET_LONG_LONG_C # define BN_MP_GET_MAG_U32_C # define BN_MP_GET_MAG_ULL_C # define BN_MP_GET_MAG_UL_C # define BN_MP_IMPORT_C # define BN_MP_INIT_SET_INT_C # define BN_MP_INIT_U32_C # define BN_MP_INVMOD_SLOW_C # define BN_MP_JACOBI_C # define BN_MP_KARATSUBA_MUL_C # define BN_MP_KARATSUBA_SQR_C # define BN_MP_KRONECKER_C # define BN_MP_N_ROOT_C # define BN_MP_N_ROOT_EX_C # define BN_MP_OR_C # define BN_MP_PACK_C # define BN_MP_PRIME_IS_DIVISIBLE_C # define BN_MP_PRIME_RANDOM_EX_C # define BN_MP_RAND_DIGIT_C # define BN_MP_READ_SIGNED_BIN_C # define BN_MP_READ_UNSIGNED_BIN_C # define BN_MP_ROOT_U32_C # define BN_MP_SBIN_SIZE_C # define BN_MP_SET_INT_C # define BN_MP_SET_LONG_C # define BN_MP_SET_LONG_LONG_C # define BN_MP_SET_U32_C # define BN_MP_SET_U64_C # define BN_MP_SIGNED_BIN_SIZE_C # define BN_MP_SIGNED_RSH_C # define BN_MP_TC_AND_C # define BN_MP_TC_DIV_2D_C # define BN_MP_TC_OR_C # define BN_MP_TC_XOR_C # define BN_MP_TOOM_MUL_C | > > > > > > > > > > > | 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 | # define BN_FAST_MP_MONTGOMERY_REDUCE_C # define BN_FAST_S_MP_MUL_DIGS_C # define BN_FAST_S_MP_MUL_HIGH_DIGS_C # define BN_FAST_S_MP_SQR_C # define BN_MP_AND_C # define BN_MP_BALANCE_MUL_C # define BN_MP_CMP_D_C # define BN_MP_DIV_3_C # define BN_MP_EXPORT_C # define BN_MP_EXPTMOD_FAST_C # define BN_MP_EXPT_D_C # define BN_MP_EXPT_D_EX_C # define BN_MP_EXPT_N_C # define BN_MP_EXPT_U32_C # define BN_MP_FROM_SBIN_C # define BN_MP_FROM_UBIN_C # define BN_MP_GET_BIT_C # define BN_MP_GET_INT_C # define BN_MP_GET_LL_C # define BN_MP_GET_LONG_C # define BN_MP_GET_LONG_LONG_C # define BN_MP_GET_MAG_U32_C # define BN_MP_GET_MAG_U64_C # define BN_MP_GET_MAG_ULL_C # define BN_MP_GET_MAG_UL_C # define BN_MP_IMPORT_C # define BN_MP_INIT_LL_C # define BN_MP_INIT_SET_INT_C # define BN_MP_INIT_U32_C # define BN_MP_INIT_ULL_C # define BN_MP_INVMOD_SLOW_C # define BN_MP_JACOBI_C # define BN_MP_KARATSUBA_MUL_C # define BN_MP_KARATSUBA_SQR_C # define BN_MP_KRONECKER_C # define BN_MP_LOG_N_C # define BN_MP_LOG_U32_C # define BN_MP_N_ROOT_C # define BN_MP_N_ROOT_EX_C # define BN_MP_OR_C # define BN_MP_PACK_C # define BN_MP_PRIME_IS_DIVISIBLE_C # define BN_MP_PRIME_RANDOM_EX_C # define BN_MP_RAND_DIGIT_C # define BN_MP_READ_SIGNED_BIN_C # define BN_MP_READ_UNSIGNED_BIN_C # define BN_MP_ROOT_N_C # define BN_MP_ROOT_U32_C # define BN_MP_SBIN_SIZE_C # define BN_MP_SET_INT_C # define BN_MP_SET_LL_C # define BN_MP_SET_LONG_C # define BN_MP_SET_LONG_LONG_C # define BN_MP_SET_U32_C # define BN_MP_SET_U64_C # define BN_MP_SET_ULL_C # define BN_MP_SIGNED_BIN_SIZE_C # define BN_MP_SIGNED_RSH_C # define BN_MP_TC_AND_C # define BN_MP_TC_DIV_2D_C # define BN_MP_TC_OR_C # define BN_MP_TC_XOR_C # define BN_MP_TOOM_MUL_C |
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 | # define BN_MP_TO_UNSIGNED_BIN_C # define BN_MP_TO_UNSIGNED_BIN_N_C # define BN_MP_UBIN_SIZE_C # define BN_MP_UNPACK_C # define BN_MP_UNSIGNED_BIN_SIZE_C # define BN_MP_XOR_C # define BN_S_MP_BALANCE_MUL_C # define BN_S_MP_EXPTMOD_FAST_C # define BN_S_MP_GET_BIT_C # define BN_S_MP_INVMOD_FAST_C # define BN_S_MP_INVMOD_SLOW_C # define BN_S_MP_KARATSUBA_MUL_C # define BN_S_MP_KARATSUBA_SQR_C # define BN_S_MP_MONTGOMERY_REDUCE_FAST_C | > | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | # define BN_MP_TO_UNSIGNED_BIN_C # define BN_MP_TO_UNSIGNED_BIN_N_C # define BN_MP_UBIN_SIZE_C # define BN_MP_UNPACK_C # define BN_MP_UNSIGNED_BIN_SIZE_C # define BN_MP_XOR_C # define BN_S_MP_BALANCE_MUL_C # define BN_S_MP_DIV_3_C # define BN_S_MP_EXPTMOD_FAST_C # define BN_S_MP_GET_BIT_C # define BN_S_MP_INVMOD_FAST_C # define BN_S_MP_INVMOD_SLOW_C # define BN_S_MP_KARATSUBA_MUL_C # define BN_S_MP_KARATSUBA_SQR_C # define BN_S_MP_MONTGOMERY_REDUCE_FAST_C |
| ︙ | ︙ | |||
365 366 367 368 369 370 371 | # define BN_MP_CLAMP_C # define BN_MP_COPY_C # define BN_MP_MOD_2D_C # define BN_MP_RSHD_C # define BN_MP_ZERO_C #endif | < < < < < < < | | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | # define BN_MP_CLAMP_C # define BN_MP_COPY_C # define BN_MP_MOD_2D_C # define BN_MP_RSHD_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_DIV_D_C) # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_DIV_2D_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C # define BN_S_MP_DIV_3_C #endif #if defined(BN_MP_DR_IS_MODULUS_C) #endif #if defined(BN_MP_DR_REDUCE_C) # define BN_MP_CLAMP_C |
| ︙ | ︙ | |||
401 402 403 404 405 406 407 | #if defined(BN_MP_ERROR_TO_STRING_C) #endif #if defined(BN_MP_EXCH_C) #endif | | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | #if defined(BN_MP_ERROR_TO_STRING_C) #endif #if defined(BN_MP_EXCH_C) #endif #if defined(BN_MP_EXPT_N_C) # define BN_MP_CLEAR_C # define BN_MP_INIT_COPY_C # define BN_MP_MUL_C # define BN_MP_SET_C # define BN_MP_SQR_C #endif |
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | # define BN_MP_GET_MAG_U64_C #endif #if defined(BN_MP_GET_L_C) # define BN_MP_GET_MAG_UL_C #endif | < < < < < < < | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | # define BN_MP_GET_MAG_U64_C #endif #if defined(BN_MP_GET_L_C) # define BN_MP_GET_MAG_UL_C #endif #if defined(BN_MP_GET_MAG_U32_C) #endif #if defined(BN_MP_GET_MAG_U64_C) #endif #if defined(BN_MP_GET_MAG_UL_C) #endif #if defined(BN_MP_GROW_C) #endif #if defined(BN_MP_INCR_C) # define BN_MP_ADD_D_C # define BN_MP_DECR_C # define BN_MP_SET_C |
| ︙ | ︙ | |||
531 532 533 534 535 536 537 | #endif #if defined(BN_MP_INIT_L_C) # define BN_MP_INIT_C # define BN_MP_SET_L_C #endif | < < < < < | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 | #endif #if defined(BN_MP_INIT_L_C) # define BN_MP_INIT_C # define BN_MP_SET_L_C #endif #if defined(BN_MP_INIT_MULTI_C) # define BN_MP_CLEAR_C # define BN_MP_INIT_C #endif #if defined(BN_MP_INIT_SET_C) # define BN_MP_INIT_C |
| ︙ | ︙ | |||
564 565 566 567 568 569 570 | #endif #if defined(BN_MP_INIT_UL_C) # define BN_MP_INIT_C # define BN_MP_SET_UL_C #endif | < < < < < | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | #endif #if defined(BN_MP_INIT_UL_C) # define BN_MP_INIT_C # define BN_MP_SET_UL_C #endif #if defined(BN_MP_INVMOD_C) # define BN_MP_CMP_D_C # define BN_S_MP_INVMOD_FAST_C # define BN_S_MP_INVMOD_SLOW_C #endif #if defined(BN_MP_IS_SQUARE_C) |
| ︙ | ︙ | |||
612 613 614 615 616 617 618 | # define BN_MP_CMP_MAG_C # define BN_MP_DIV_C # define BN_MP_GCD_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C #endif | | < | < | < | < < < < < | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 | # define BN_MP_CMP_MAG_C # define BN_MP_DIV_C # define BN_MP_GCD_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C #endif #if defined(BN_MP_LOG_N_C) # define BN_S_MP_LOG_2EXPT_C # define BN_S_MP_LOG_C # define BN_S_MP_LOG_D_C #endif #if defined(BN_MP_LSHD_C) # define BN_MP_GROW_C #endif #if defined(BN_MP_MOD_C) |
| ︙ | ︙ | |||
925 926 927 928 929 930 931 | #endif #if defined(BN_MP_REDUCE_SETUP_C) # define BN_MP_2EXPT_C # define BN_MP_DIV_C #endif | | | | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 | #endif #if defined(BN_MP_REDUCE_SETUP_C) # define BN_MP_2EXPT_C # define BN_MP_DIV_C #endif #if defined(BN_MP_ROOT_N_C) # define BN_MP_2EXPT_C # define BN_MP_ADD_D_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_C # define BN_MP_EXCH_C # define BN_MP_EXPT_N_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C # define BN_MP_MUL_D_C # define BN_MP_SET_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C #endif |
| ︙ | ︙ | |||
972 973 974 975 976 977 978 | # define BN_MP_SET_U64_C #endif #if defined(BN_MP_SET_L_C) # define BN_MP_SET_UL_C #endif | < < < < < < < | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 | # define BN_MP_SET_U64_C #endif #if defined(BN_MP_SET_L_C) # define BN_MP_SET_UL_C #endif #if defined(BN_MP_SET_U32_C) #endif #if defined(BN_MP_SET_U64_C) #endif #if defined(BN_MP_SET_UL_C) #endif #if defined(BN_MP_SHRINK_C) #endif #if defined(BN_MP_SIGNED_RSH_C) # define BN_MP_ADD_D_C # define BN_MP_DIV_2D_C # define BN_MP_SUB_D_C |
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 | # define BN_MP_CLEAR_MULTI_C # define BN_MP_EXCH_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_C #endif #if defined(BN_S_MP_EXPTMOD_C) # define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_EXCH_C # define BN_MP_INIT_C | > > > > > > > | 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 | # define BN_MP_CLEAR_MULTI_C # define BN_MP_EXCH_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_C #endif #if defined(BN_S_MP_DIV_3_C) # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C #endif #if defined(BN_S_MP_EXPTMOD_C) # define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_EXCH_C # define BN_MP_INIT_C |
| ︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 | # define BN_MP_CLEAR_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_SQR_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_S_MP_MONTGOMERY_REDUCE_FAST_C) # define BN_MP_CLAMP_C # define BN_MP_CMP_MAG_C # define BN_MP_GROW_C # define BN_S_MP_SUB_C #endif | > > > > > > > > > > > > > > > > > > > > | 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 | # define BN_MP_CLEAR_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_SQR_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_S_MP_LOG_C) # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_COPY_C # define BN_MP_EXCH_C # define BN_MP_EXPT_N_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C # define BN_MP_SET_C # define BN_MP_SQR_C #endif #if defined(BN_S_MP_LOG_2EXPT_C) # define BN_MP_COUNT_BITS_C #endif #if defined(BN_S_MP_LOG_D_C) #endif #if defined(BN_S_MP_MONTGOMERY_REDUCE_FAST_C) # define BN_MP_CLAMP_C # define BN_MP_CMP_MAG_C # define BN_MP_GROW_C # define BN_S_MP_SUB_C #endif |
| ︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 | #if defined(BN_S_MP_TOOM_MUL_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_DIV_2_C | < > | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 | #if defined(BN_S_MP_TOOM_MUL_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_DIV_2_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_2_C # define BN_MP_MUL_C # define BN_MP_SUB_C # define BN_S_MP_DIV_3_C #endif #if defined(BN_S_MP_TOOM_SQR_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_DIV_2_C |
| ︙ | ︙ |
Changes to libtommath/tommath_private.h.
1 2 3 4 5 6 7 | /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ #ifndef TOMMATH_PRIV_H_ #define TOMMATH_PRIV_H_ #include <stdint.h> | > | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ #ifndef TOMMATH_PRIV_H_ #define TOMMATH_PRIV_H_ #include <stdint.h> #ifndef TCL_WITH_EXTERNAL_TOMMATH # include "tclTomMath.h" #else # include "tommath.h" #endif #include "tommath_class.h" /* * Private symbols * --------------- * * On Unix symbols can be marked as hidden if libtommath is compiled |
| ︙ | ︙ | |||
155 156 157 158 159 160 161 162 163 164 165 166 167 168 | #undef mp_word typedef private_mp_word mp_word; #endif #define MP_MIN(x, y) (((x) < (y)) ? (x) : (y)) #define MP_MAX(x, y) (((x) > (y)) ? (x) : (y)) /* Static assertion */ #define MP_STATIC_ASSERT(msg, cond) typedef char mp_static_assert_##msg[(cond) ? 1 : -1]; /* ---> Basic Manipulations <--- */ #define MP_IS_ZERO(a) ((a)->used == 0) #define MP_IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) #define MP_IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) | > > | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 | #undef mp_word typedef private_mp_word mp_word; #endif #define MP_MIN(x, y) (((x) < (y)) ? (x) : (y)) #define MP_MAX(x, y) (((x) > (y)) ? (x) : (y)) #define MP_IS_2EXPT(x) (((x) != 0u) && (((x) & ((x) - 1u)) == 0u)) /* Static assertion */ #define MP_STATIC_ASSERT(msg, cond) typedef char mp_static_assert_##msg[(cond) ? 1 : -1]; /* ---> Basic Manipulations <--- */ #define MP_IS_ZERO(a) ((a)->used == 0) #define MP_IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) #define MP_IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) |
| ︙ | ︙ | |||
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 | MP_STATIC_ASSERT(prec_geq_min_prec, MP_PREC >= MP_MIN_PREC) /* random number source */ extern MP_PRIVATE mp_err(*s_mp_rand_source)(void *out, size_t size); /* lowlevel functions, do not call! */ MP_PRIVATE mp_bool s_mp_get_bit(const mp_int *a, unsigned int b); MP_PRIVATE mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_mul_high_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_sqr_fast(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_sqr(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_karatsuba_sqr(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_toom_sqr(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_invmod_fast(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_montgomery_reduce_fast(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR; MP_PRIVATE mp_err s_mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR; MP_PRIVATE mp_err s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR; MP_PRIVATE mp_err s_mp_rand_platform(void *p, size_t n) MP_WUR; MP_PRIVATE mp_err s_mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat); MP_PRIVATE void s_mp_reverse(unsigned char *s, size_t len); MP_PRIVATE mp_err s_mp_prime_is_divisible(const mp_int *a, mp_bool *result); /* TODO: jenkins prng is not thread safe as of now */ MP_PRIVATE mp_err s_mp_rand_jenkins(void *p, size_t n) MP_WUR; | > > > > | 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 | MP_STATIC_ASSERT(prec_geq_min_prec, MP_PREC >= MP_MIN_PREC) /* random number source */ extern MP_PRIVATE mp_err(*s_mp_rand_source)(void *out, size_t size); /* lowlevel functions, do not call! */ MP_PRIVATE mp_bool s_mp_get_bit(const mp_int *a, unsigned int b); MP_PRIVATE int s_mp_log_2expt(const mp_int *a, mp_digit base) MP_WUR; MP_PRIVATE int s_mp_log_d(mp_digit base, mp_digit n) MP_WUR; MP_PRIVATE mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR; MP_PRIVATE mp_err s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_mul_high_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; MP_PRIVATE mp_err s_mp_sqr_fast(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_sqr(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_karatsuba_sqr(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_toom_sqr(const mp_int *a, mp_int *b) MP_WUR; MP_PRIVATE mp_err s_mp_invmod_fast(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; MP_PRIVATE mp_err s_mp_montgomery_reduce_fast(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR; MP_PRIVATE mp_err s_mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR; MP_PRIVATE mp_err s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR; MP_PRIVATE mp_err s_mp_log(const mp_int *a, mp_digit base, int *c) MP_WUR; MP_PRIVATE mp_err s_mp_rand_platform(void *p, size_t n) MP_WUR; MP_PRIVATE mp_err s_mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat); MP_PRIVATE void s_mp_reverse(unsigned char *s, size_t len); MP_PRIVATE mp_err s_mp_prime_is_divisible(const mp_int *a, mp_bool *result); /* TODO: jenkins prng is not thread safe as of now */ MP_PRIVATE mp_err s_mp_rand_jenkins(void *p, size_t n) MP_WUR; |
| ︙ | ︙ |
Changes to libtommath/win32/libtommath.dll.
cannot compute difference between binary files
Changes to libtommath/win32/tommath.lib.
cannot compute difference between binary files
Changes to libtommath/win64-arm/libtommath.dll.
cannot compute difference between binary files
Changes to libtommath/win64-arm/tommath.lib.
cannot compute difference between binary files
Changes to libtommath/win64/libtommath.dll.
cannot compute difference between binary files
Changes to libtommath/win64/tommath.lib.
cannot compute difference between binary files
Changes to macosx/README.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | (see below for details), but can also be built with the standard unix configure and make buildsystem in tcl/unix as on any other unix platform (indeed, the GNUmakefile is just a wrapper around the unix buildsystem). The Mac OS X specific configure flags are --enable-framework and --disable-corefoundation (which disables CF and notably reverts to the standard select based notifier). | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 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 |
(see below for details), but can also be built with the standard unix configure
and make buildsystem in tcl/unix as on any other unix platform (indeed, the
GNUmakefile is just a wrapper around the unix buildsystem).
The Mac OS X specific configure flags are --enable-framework and
--disable-corefoundation (which disables CF and notably reverts to the standard
select based notifier).
- To build universal binaries outside of the Xcode IDE, set CFLAGS as follows:
export CFLAGS="-arch x86_64 -arch arm64"
This requires Mac OS X 10.6 and Xcode 10.2 and will work on any architecture.
Note that configure requires CFLAGS to contain a least one architecture that can
be run on the build machine (i.e. x86_64 on Core2/Xeon).
Universal builds of Tcl TEA extensions are also possible with CFLAGS set as
above, they will be [load]able by universal as well as thin binaries of Tcl.
Detailed Instructions for building with macosx/GNUmakefile
----------------------------------------------------------
- Unpack the Tcl source release archive.
- The following instructions assume the Tcl source tree is named "tcl${ver}",
(where ${ver} is a shell variable containing the Tcl version number e.g. '9.0').
Setup this shell variable as follows:
ver="9.0"
- Setup environment variables as desired, e.g. for a universal build on 10.9:
CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.9"
export CFLAGS
- Change to the directory containing the Tcl source tree and build:
make -C tcl${ver}/macosx
- Install Tcl onto the root volume (admin password required):
sudo make -C tcl${ver}/macosx install
|
| ︙ | ︙ |
Deleted macosx/Tcl-Common.xcconfig.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted macosx/Tcl-Debug.xcconfig.
|
| < < < < < < < < < < < < < < < < < < < < |
Deleted macosx/Tcl-Release.xcconfig.
|
| < < < < < < < < < < < < < < < < < < < < |
Deleted macosx/Tcl.xcodeproj/default.pbxuser.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted macosx/Tcl.xcodeproj/project.pbxproj.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to macosx/tclMacOSXBundle.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #include "tclPort.h" #include "tclInt.h" #ifdef HAVE_COREFOUNDATION #include <CoreFoundation/CoreFoundation.h> | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#include "tclPort.h"
#include "tclInt.h"
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
#include <dlfcn.h>
#ifdef TCL_DEBUG_LOAD
#define TclLoadDbgMsg(m, ...) \
do { \
fprintf(stderr, "%s:%d: %s(): " m ".\n", \
strrchr(__FILE__, '/')+1, __LINE__, __func__, \
##__VA_ARGS__); \
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
OpenResourceMap(
CFBundleRef bundleRef)
{
static int initialized = FALSE;
static short (*openresourcemap)(CFBundleRef) = NULL;
if (!initialized) {
| < < < < < < < < < < < < < < < < < < < | 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 |
OpenResourceMap(
CFBundleRef bundleRef)
{
static int initialized = FALSE;
static short (*openresourcemap)(CFBundleRef) = NULL;
if (!initialized) {
{
openresourcemap = (short (*)(CFBundleRef))dlsym(RTLD_NEXT,
"CFBundleOpenBundleResourceMap");
#ifdef TCL_DEBUG_LOAD
if (!openresourcemap) {
const char *errMsg = dlerror();
TclLoadDbgMsg("dlsym() failed: %s", errMsg);
}
#endif /* TCL_DEBUG_LOAD */
}
initialized = TRUE;
}
if (openresourcemap) {
return openresourcemap(bundleRef);
}
return -1;
|
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
*/
CFURLGetFileSystemRepresentation(libURL, TRUE,
(unsigned char *) libraryPath, maxPathLen);
CFRelease(libURL);
}
if (versionedBundleRef) {
| < < < < < < < | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
*/
CFURLGetFileSystemRepresentation(libURL, TRUE,
(unsigned char *) libraryPath, maxPathLen);
CFRelease(libURL);
}
if (versionedBundleRef) {
{
CFRelease(versionedBundleRef);
}
}
}
if (libraryPath[0]) {
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | #include <libkern/OSByteOrder.h> #endif /* Darwin 8 copyfile API. */ #ifdef HAVE_COPYFILE #ifdef HAVE_COPYFILE_H #include <copyfile.h> | < < < < < < < < < < < < < < | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | #include <libkern/OSByteOrder.h> #endif /* Darwin 8 copyfile API. */ #ifdef HAVE_COPYFILE #ifdef HAVE_COPYFILE_H #include <copyfile.h> #else /* HAVE_COPYFILE_H */ int copyfile(const char *from, const char *to, void *state, uint32_t flags); #define COPYFILE_ACL (1<<0) #define COPYFILE_XATTR (1<<2) #define COPYFILE_NOFOLLOW_SRC (1<<18) #endif /* HAVE_COPYFILE_H */ #endif /* HAVE_COPYFILE */ #ifdef WEAK_IMPORT_COPYFILE #define MayUseCopyFile() (copyfile != NULL) #elif defined(HAVE_COPYFILE) #define MayUseCopyFile() (1) |
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
TclNewIntObj(*attributePtrPtr, *rsrcForkSize);
break;
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", TCL_INDEX_NONE));
| | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
TclNewIntObj(*attributePtrPtr, *rsrcForkSize);
break;
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (char *)NULL);
return TCL_ERROR;
#endif /* HAVE_GETATTRLIST */
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
* Only setting rsrclength to 0 to strip a file's resource fork is
* supported.
*/
if (newRsrcForkSize != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"setting nonzero rsrclength not supported", TCL_INDEX_NONE));
| | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
* Only setting rsrclength to 0 to strip a file's resource fork is
* supported.
*/
if (newRsrcForkSize != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"setting nonzero rsrclength not supported", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (char *)NULL);
return TCL_ERROR;
}
/*
* Construct path to resource fork.
*/
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
}
}
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", TCL_INDEX_NONE));
| | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
}
}
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (char *)NULL);
return TCL_ERROR;
#endif
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
{
const char *string;
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
Tcl_Size length;
| | | | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 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 = TclGetStringFromObj(objPtr, &length);
Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, TCL_ENCODING_PROFILE_TCL8, &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", (char *)NULL);
}
result = TCL_ERROR;
} else {
OSType osType;
char bytes[4] = {'\0','\0','\0','\0'};
memcpy(bytes, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXNotify.c.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | * In macOS 10.12 the os_unfair_lock was introduced as a replacement for the * OSSpinLock, and the OSSpinLock was deprecated. */ #if MAC_OS_X_VERSION_MIN_REQUIRED >= 101200 #define USE_OS_UNFAIR_LOCK #include <os/lock.h> | < < < | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | * In macOS 10.12 the os_unfair_lock was introduced as a replacement for the * OSSpinLock, and the OSSpinLock was deprecated. */ #if MAC_OS_X_VERSION_MIN_REQUIRED >= 101200 #define USE_OS_UNFAIR_LOCK #include <os/lock.h> #endif #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include <CoreFoundation/CoreFoundation.h> #include <pthread.h> #if !defined(USE_OS_UNFAIR_LOCK) /* * We use the Darwin-native spinlock API rather than pthread mutexes for * notifier locking: this radically simplifies the implementation and lowers * overhead. Note that these are not pure spinlocks, they employ various * strategies to back off and relinquish the processor, making them immune to |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | #pragma GCC diagnostic ignored "-Wunused-function" /* * Use OSSpinLock API where available (Tiger or later). */ #include <libkern/OSAtomic.h> | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
#pragma GCC diagnostic ignored "-Wunused-function"
/*
* Use OSSpinLock API where available (Tiger or later).
*/
#include <libkern/OSAtomic.h>
/*
* Wrappers so that we get warnings in just one small part of this file.
*/
static inline void
SpinLockLock(
OSSpinLock *lock)
|
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
}
static inline bool
SpinLockTry(
OSSpinLock *lock)
{
return OSSpinLockTry(lock);
}
| < | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
}
static inline bool
SpinLockTry(
OSSpinLock *lock)
{
return OSSpinLockTry(lock);
}
#define SPINLOCK_INIT OS_SPINLOCK_INIT
#else
/*
* Otherwise, use commpage spinlock SPI directly.
*/
|
| ︙ | ︙ | |||
216 217 218 219 220 221 222 | #define UNLOCK_NOTIFIER_INIT SpinLockUnlock(¬ifierInitLock) #define LOCK_NOTIFIER SpinLockLock(¬ifierLock) #define UNLOCK_NOTIFIER SpinLockUnlock(¬ifierLock) #define LOCK_NOTIFIER_TSD SpinLockLock(&tsdPtr->tsdLock) #define UNLOCK_NOTIFIER_TSD SpinLockUnlock(&tsdPtr->tsdLock) #endif | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
#define UNLOCK_NOTIFIER_INIT SpinLockUnlock(¬ifierInitLock)
#define LOCK_NOTIFIER SpinLockLock(¬ifierLock)
#define UNLOCK_NOTIFIER SpinLockUnlock(¬ifierLock)
#define LOCK_NOTIFIER_TSD SpinLockLock(&tsdPtr->tsdLock)
#define UNLOCK_NOTIFIER_TSD SpinLockUnlock(&tsdPtr->tsdLock)
#endif
/*
* This structure is used to keep track of the notifier info for a registered
* file.
*/
typedef struct FileHandler {
int fd;
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
CFRunLoopTimerRef runLoopTimer;
/* Wakes up CFRunLoop after given timeout when
* running embedded. */
/* End tsdLock section */
CFTimeInterval waitTime; /* runLoopTimer wait time when running
* embedded. */
| < | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
CFRunLoopTimerRef runLoopTimer;
/* Wakes up CFRunLoop after given timeout when
* running embedded. */
/* End tsdLock section */
CFTimeInterval waitTime; /* runLoopTimer wait time when running
* embedded. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* The following static indicates the number of threads that have initialized
* notifiers.
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 | int onList, int signalNotifier); #ifdef HAVE_PTHREAD_ATFORK static int atForkInit = 0; static void AtForkPrepare(void); static void AtForkParent(void); static void AtForkChild(void); | < < < < < < < < < < < < < < < < < < < < < < | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 | int onList, int signalNotifier); #ifdef HAVE_PTHREAD_ATFORK static int atForkInit = 0; static void AtForkPrepare(void); static void AtForkParent(void); static void AtForkChild(void); #endif /* HAVE_PTHREAD_ATFORK */ /* *---------------------------------------------------------------------- * * LookUpFileHandler -- * |
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
LOCK_NOTIFIER_INIT;
#ifdef HAVE_PTHREAD_ATFORK
/*
* Install pthread_atfork handlers to reinitialize the notifier in the
* child of a fork.
*/
| | | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 |
LOCK_NOTIFIER_INIT;
#ifdef HAVE_PTHREAD_ATFORK
/*
* Install pthread_atfork handlers to reinitialize the notifier in the
* child of a fork.
*/
if (!atForkInit) {
int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild);
if (result) {
Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed");
}
atForkInit = 1;
}
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 | /* * Create notifier thread lazily in Tcl_WaitForEvent() to avoid * interfering with fork() followed immediately by execve() (we cannot * execve() when more than one thread is present). */ notifierThreadRunning = 0; | < < | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
/*
* Create notifier thread lazily in Tcl_WaitForEvent() to avoid
* interfering with fork() followed immediately by execve() (we cannot
* execve() when more than one thread is present).
*/
notifierThreadRunning = 0;
}
notifierCount++;
UNLOCK_NOTIFIER_INIT;
return tsdPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
* Restore original signal mask.
*/
pthread_sigmask(SIG_SETMASK, ¬ifierSigMask, NULL);
}
UNLOCK_NOTIFIER_INIT;
}
| < | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
* Restore original signal mask.
*/
pthread_sigmask(SIG_SETMASK, ¬ifierSigMask, NULL);
}
UNLOCK_NOTIFIER_INIT;
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeNotifier --
*
* This function is called to cleanup the notifier state before a thread
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
TclpFinalizeNotifier(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
LOCK_NOTIFIER_INIT;
notifierCount--;
| < | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 |
TclpFinalizeNotifier(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
LOCK_NOTIFIER_INIT;
notifierCount--;
/*
* If this is the last thread to use the notifier, close the notifier pipe
* and wait for the background thread to terminate.
*/
if (notifierCount == 0) {
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 | TclAsyncMarkFromNotifier(); } } close(receivePipe); triggerPipe = -1; } | < | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
TclAsyncMarkFromNotifier();
}
}
close(receivePipe);
triggerPipe = -1;
}
}
UNLOCK_NOTIFIER_INIT;
LOCK_NOTIFIER_TSD; /* For concurrency with Tcl_AlertNotifier */
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
|
| ︙ | ︙ | |||
1318 1319 1320 1321 1322 1323 1324 | } /* *---------------------------------------------------------------------- * * TclpNotifierData -- * | | | 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 | } /* *---------------------------------------------------------------------- * * TclpNotifierData -- * * This function returns a void pointer to be associated * with a Tcl_AsyncHandler. * * Results: * On MacOSX, returns always NULL. * * Side effects: * None. |
| ︙ | ︙ | |||
1603 1604 1605 1606 1607 1608 1609 |
OnOffWaitingList(
ThreadSpecificData *tsdPtr,
int onList,
int signalNotifier)
{
int changeWaitingList;
| < < < < < | 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
OnOffWaitingList(
ThreadSpecificData *tsdPtr,
int onList,
int signalNotifier)
{
int changeWaitingList;
changeWaitingList = (!onList ^ !tsdPtr->onList);
if (changeWaitingList) {
if (onList) {
tsdPtr->nextPtr = waitingListPtr;
if (waitingListPtr) {
waitingListPtr->prevPtr = tsdPtr;
}
|
| ︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 |
if (tsdPtr->runLoop) {
CFTimeInterval waitTime;
CFRunLoopTimerRef runLoopTimer = tsdPtr->runLoopTimer;
CFAbsoluteTime nextTimerFire = 0, waitEnd, now;
SInt32 runLoopStatus;
waitTime = vdelay.sec + 1.0e-6 * vdelay.usec;
| | < | | 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 |
if (tsdPtr->runLoop) {
CFTimeInterval waitTime;
CFRunLoopTimerRef runLoopTimer = tsdPtr->runLoopTimer;
CFAbsoluteTime nextTimerFire = 0, waitEnd, now;
SInt32 runLoopStatus;
waitTime = vdelay.sec + 1.0e-6 * vdelay.usec;
now = CFAbsoluteTimeGetCurrent();
waitEnd = now + waitTime;
if (runLoopTimer) {
nextTimerFire = CFRunLoopTimerGetNextFireDate(runLoopTimer);
if (nextTimerFire < waitEnd) {
CFRunLoopTimerSetNextFireDate(runLoopTimer, now +
CF_TIMEINTERVAL_FOREVER);
} else {
runLoopTimer = NULL;
}
}
tsdPtr->sleeping = 1;
do {
runLoopStatus = CFRunLoopRunInMode(kCFRunLoopDefaultMode,
waitTime, FALSE);
switch (runLoopStatus) {
case kCFRunLoopRunFinished:
Tcl_Panic("Tcl_Sleep: CFRunLoop finished");
break;
case kCFRunLoopRunStopped:
waitTime = waitEnd - CFAbsoluteTimeGetCurrent();
break;
case kCFRunLoopRunTimedOut:
waitTime = 0;
break;
}
} while (waitTime > 0);
tsdPtr->sleeping = 0;
if (runLoopTimer) {
CFRunLoopTimerSetNextFireDate(runLoopTimer, nextTimerFire);
}
} else {
struct timespec waitTime;
waitTime.tv_sec = vdelay.sec;
waitTime.tv_nsec = vdelay.usec * 1000;
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 |
#ifndef _DARWIN_C_SOURCE
/*
* Sanity check fd.
*/
if (fd >= FD_SETSIZE) {
| | | 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 |
#ifndef _DARWIN_C_SOURCE
/*
* Sanity check fd.
*/
if (fd >= FD_SETSIZE) {
Tcl_Panic("TclUnixWaitForFile cannot handle file id %d", fd);
/* must never get here, or select masks overrun will occur below */
}
#endif
/*
* If there is a non-zero finite timeout, compute the time when we give
* up.
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 |
UNLOCK_NOTIFIER_INIT;
#endif
asyncPending = 0;
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
| < < < < < < < < < < < < < < < < < < < < < | 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 |
UNLOCK_NOTIFIER_INIT;
#endif
asyncPending = 0;
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
tsdPtr->runLoopSource = NULL;
tsdPtr->runLoopTimer = NULL;
}
if (notifierCount > 0) {
notifierCount = 1;
notifierThreadRunning = 0;
/*
* Restart the notifier thread for signal handling.
*/
StartNotifierThread();
}
}
|
| ︙ | ︙ |
Changes to tests-perf/chan.perf.tcl.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 |
namespace eval ::tclTestPerf-Chan {
namespace path {::tclTestPerf}
proc _get_test_chan {{bufSize 4096}} {
lassign [chan pipe] ch wch;
| | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
namespace eval ::tclTestPerf-Chan {
namespace path {::tclTestPerf}
proc _get_test_chan {{bufSize 4096}} {
lassign [chan pipe] ch wch;
fconfigure $ch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
fconfigure $wch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
exec [info nameofexecutable] -- $bufSize >@$wch << {
set bufSize [lindex $::argv end]
fconfigure stdout -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
set buf [string repeat test 1000]; # 4K
# write ~ 10*1M + 10*2M + 10*10M + 1*20M:
set i 0; while {$i < int((10*1e6 + 10*2e6 + 10*10e6 + 1*20e6)/4e3)} {
#puts -nonewline stdout $i\t
puts stdout $buf
#flush stdout; # don't flush to use full buffer
incr i
|
| ︙ | ︙ |
Changes to tests-perf/clock.perf.tcl.
| ︙ | ︙ | |||
351 352 353 354 355 356 357 358 359 |
proc test-other {{reptime 1000}} {
_test_run $reptime {
# Bad zone
{catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
# Scan : julian day (overflow)
{catch {clock scan 5373485 -format %J}}
# Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference)
| > > > | > | > > | 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 |
proc test-other {{reptime 1000}} {
_test_run $reptime {
# Bad zone
{catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
# Scan : julian day (overflow)
{catch {clock scan 5373485 -format %J}}
setup {set _(org-reptime) $_(reptime); lset _(reptime) 1 50}
# Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference)
setup {set i -1}
{clock scan "[incr i] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1}
# Scan : test reusability of GC objects (format is dynamic, so tcl-obj removed with last reference)
setup {incr i; set j $i}
{clock scan "[incr j -1] - 25.11.2015" -format "$j - %d.%m.%Y" -base 0 -gmt 1}
setup {set _(reptime) $_(org-reptime); set j $i}
{clock scan "[incr j -1] - 25.11.2015" -format "$j - %d.%m.%Y" -base 0 -gmt 1; if {!$j} {set j $i}}
}
}
proc test-ensemble-perf {{reptime 1000}} {
_test_run $reptime {
# Clock clicks (ensemble)
{clock clicks}
|
| ︙ | ︙ |
Changes to tests-perf/comparePerf.tcl.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
set runtimes [dict create]
set path [file normalize $testrun_path]
set fd [open $path]
array set header {}
while {[gets $fd line] >= 0} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set runtimes [dict create]
set path [file normalize $testrun_path]
set fd [open $path]
array set header {}
while {[gets $fd line] >= 0} {
set line [regsub -all {\s+} [string trim $line] " "]
switch -glob -- $line {
"#*" {
# Skip comments
}
"R *" -
"L *" -
"D *" -
"V *" -
"T *" -
"E *" {
set marker [lindex $line 0]
if {[info exists header($marker)]} {
warn "Ignoring $marker record (duplicate): \"$line\""
}
set header($marker) [string range $line 2 end]
}
"P *" {
if {[scan $line "P %f %n" runtime id_start] == 2} {
set id [string range $line $id_start end]
if {[dict exists $runtimes $id]} {
warn "Ignoring duplicate test id \"$id\""
} else {
dict set runtimes $id $runtime
}
} else {
warn "Invalid test result line format: \"$line\""
}
}
default {
puts stderr "Warning: ignoring unrecognized line \"$line\""
}
}
}
close $fd
set result [dict create Input $path Runtimes $runtimes]
foreach {c k} {
L Label
V Version
E Executable
D Description
} {
if {[info exists header($c)]} {
dict set result $k $header($c)
}
}
return $result
}
proc perf::compare::burp {test_sets} {
variable Options
# Print the key for each test run
set header " "
set separator " "
foreach test_set $test_sets {
set test_set_key "\[[incr test_set_num]\]"
if {! $Options(--no-header)} {
print "$test_set_key"
foreach k {Label Executable Version Input Description} {
if {[dict exists $test_set $k]} {
print "$k: [dict get $test_set $k]"
}
}
}
append header $test_set_key $separator
set separator " "; # Expand because later columns have ratio
}
set header [string trimright $header]
if {! $Options(--no-header)} {
print ""
if {$Options(--ratio) eq "rate"} {
set ratio_description "ratio of baseline to the measurement (higher is faster)."
} else {
set ratio_description "ratio of measurement to the baseline (lower is faster)."
}
print "The first column \[1\] is the baseline measurement."
print "Subsequent columns are pairs of the additional measurement and "
print $ratio_description
print ""
}
# Print the actual test run data
print $header
set test_sets [lassign $test_sets base_set]
set fmt {%#10.5f}
set fmt_ratio {%-6.2f}
foreach {id base_runtime} [dict get $base_set Runtimes] {
if {[info exists Options(--regexp)]} {
if {![regexp $Options(--regexp) $id]} {
continue
}
}
if {$Options(--print-test-number)} {
set line "[format %-4s [incr counter].]"
} else {
set line ""
}
append line [format $fmt $base_runtime]
foreach test_set $test_sets {
if {[dict exists $test_set Runtimes $id]} {
set runtime [dict get $test_set Runtimes $id]
if {$Options(--ratio) eq "time"} {
if {$base_runtime != 0} {
set ratio [format $fmt_ratio [expr {$runtime/$base_runtime}]]
} else {
if {$runtime == 0} {
set ratio "NaN "
} else {
set ratio "Inf "
}
}
} else {
if {$runtime != 0} {
set ratio [format $fmt_ratio [expr {$base_runtime/$runtime}]]
} else {
if {$base_runtime == 0} {
set ratio "NaN "
} else {
set ratio "Inf "
}
}
}
append line "|" [format $fmt $runtime] "|" $ratio
} else {
append line [string repeat { } 11]
}
}
append line "|" $id
print $line
}
}
proc perf::compare::chew {test_sets} {
variable Options
# Combine test sets that have the same label, averaging the values
set unlabeled_sets {}
array set labeled_sets {}
foreach test_set $test_sets {
# If there is no label, treat as independent set
if {![dict exists $test_set Label]} {
lappend unlabeled_sets $test_set
} else {
lappend labeled_sets([dict get $test_set Label]) $test_set
}
}
foreach label [array names labeled_sets] {
set combined_set [lindex $labeled_sets($label) 0]
set runtimes [dict get $combined_set Runtimes]
foreach test_set [lrange $labeled_sets($label) 1 end] {
dict for {id timing} [dict get $test_set Runtimes] {
dict lappend runtimes $id $timing
}
}
dict for {id timings} $runtimes {
set total [tcl::mathop::+ {*}$timings]
dict set runtimes $id [expr {$total/[llength $timings]}]
}
dict set combined_set Runtimes $runtimes
set labeled_sets($label) $combined_set
}
# Choose the "base" test set
if {![info exists Options(--base)]} {
set first_set [lindex $test_sets 0]
if {[dict exists $first_set Label]} {
# Use label of first as the base
set Options(--base) [dict get $first_set Label]
}
}
if {[info exists Options(--base)] && $Options(--base) ne ""} {
lappend combined_sets $labeled_sets($Options(--base));# Will error if no such
unset labeled_sets($Options(--base))
} else {
lappend combined_sets [lindex $unlabeled_sets 0]
set unlabeled_sets [lrange $unlabeled_sets 1 end]
}
foreach label [array names labeled_sets] {
lappend combined_sets $labeled_sets($label)
}
lappend combined_sets {*}$unlabeled_sets
return $combined_sets
}
proc perf::compare::setup {argv} {
variable Options
array set Options {
--ratio rate
--combine 0
--print-test-number 0
--no-header 0
}
while {[llength $argv]} {
set argv [lassign $argv arg]
switch -glob -- $arg {
-r -
--regexp {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Options(--regexp) $val
}
--ratio {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
if {$val ni {time rate}} {
error "Value for option $arg must be either \"time\" or \"rate\""
}
set Options(--ratio) $val
}
--print-test-number -
--combine -
--no-header {
set Options($arg) 1
}
--base {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Options($arg) $val
}
-- {
# Remaining will be passed back to the caller
break
}
--* {
error "Unknown option $arg"
}
-* {
error "Unknown option -[lindex $arg 0]"
}
default {
# Remaining will be passed back to the caller
set argv [linsert $argv 0 $arg]
break;
}
}
}
set paths {}
foreach path $argv {
set path [file join $path]; # Convert from native else glob fails
if {[file isfile $path]} {
lappend paths $path
continue
}
if {[file isfile $path.perf]} {
lappend paths $path.perf
continue
}
lappend paths {*}[glob -nocomplain $path]
}
return $paths
}
proc perf::compare::main {} {
variable Options
set paths [setup $::argv]
if {[llength $paths] == 0} {
error "No test data files specified."
}
set test_data [list ]
set seen [dict create]
foreach path $paths {
if {![dict exists $seen $path]} {
lappend test_data [slurp $path]
dict set seen $path ""
}
}
if {$Options(--combine)} {
set test_data [chew $test_data]
}
burp $test_data
}
perf::compare::main
|
Added tests-perf/file.perf.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 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 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# file.perf.tcl --
#
# This file provides performance tests for comparison of tcl-speed
# of file commands and subsystem.
#
# ------------------------------------------------------------------------
#
# Copyright (c) 2024 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
if {![namespace exists ::tclTestPerf]} {
source -encoding utf-8 [file join [file dirname [info script]] test-performance.tcl]
}
namespace eval ::tclTestPerf-File {
namespace path {::tclTestPerf}
proc _get_new_file_path_obj [list [list p [info script]]] {
# always generate new string object here (ensure it is not a "cached" object of type path):
string trimright "$p "; # costs of object "creation" smaller than 1 microsecond
}
# regression tests for bug-02d5d65d70adab97 (fix for [02d5d65d70adab97]):
proc test-file-access-regress {{reptime 1000}} {
_test_run -no-result $reptime {
setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] }
# file exists on "cached" file path:
{ file exists $fn }
# file exists on not "cached" (fresh generated) file path:
{ set fn [::tclTestPerf-File::_get_new_file_path_obj]; file exists $fn }
setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] }
# file attributes on "cached" file path:
{ file attributes $fn -readonly }
# file attributes on not "cached" (fresh generated) file path:
{ set fn [::tclTestPerf-File::_get_new_file_path_obj]; file attributes $fn -readonly }
setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] }
# file stat on "cached" file path:
{ file stat $fn st }
# file stat on not "cached" (fresh generated) file path:
{ set fn [::tclTestPerf-File::_get_new_file_path_obj]; file stat $fn st }
setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] }
# touch on "cached" file path:
{ close [open $fn rb] }
# touch on not "cached" (fresh generated) file path:
{ set fn [::tclTestPerf-File::_get_new_file_path_obj]; close [open $fn rb] }
}
}
proc test {{reptime 1000}} {
test-file-access-regress $reptime
puts \n**OK**
}
}; # end of ::tclTestPerf-File
# ------------------------------------------------------------------------
# if calling direct:
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
array set in {-time 500}
array set in $argv
::tclTestPerf-File::test $in(-time)
}
|
Added tests-perf/list.perf.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 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 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# list.perf.tcl --
#
# This file provides performance tests for comparison of tcl-speed
# of list facilities.
#
# ------------------------------------------------------------------------
#
# Copyright (c) 2024 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
if {![namespace exists ::tclTestPerf]} {
source [file join [file dirname [info script]] test-performance.tcl]
}
namespace eval ::tclTestPerf-List {
namespace path {::tclTestPerf}
proc test-lsearch-regress {{reptime 1000}} {
_test_run -no-result $reptime {
# found-first immediately, list with 5000 strings with ca. 50 chars elements:
setup { set str [join [lrepeat 13 "XXX"] /]; set l [lrepeat 5000 $str]; llength $l }
{ lsearch $l $str }
{ lsearch -glob $l $str }
{ lsearch -exact $l $str }
{ lsearch -dictionary $l $str }
{ lsearch -exact -dictionary $l $str }
{ lsearch -nocase $l $str }
{ lsearch -nocase -glob $l $str }
{ lsearch -nocase -exact $l $str }
{ lsearch -nocase -dictionary $l $str }
{ lsearch -nocase -exact -dictionary $l $str }
}
}
proc test-lsearch-nf-regress {{reptime 1000}} {
_test_run -no-result $reptime {
# not-found, list with 5000 strings with ca. 50 chars elements:
setup { set str [join [lrepeat 13 "XXX"] /]; set sNF $str/NF; set l [lrepeat 5000 $str]; llength $l }
{ lsearch $l $sNF }
{ lsearch -glob $l $sNF }
{ lsearch -exact $l $sNF }
{ lsearch -dictionary $l $sNF }
{ lsearch -exact -dictionary $l $sNF }
{ lsearch -sorted $l $sNF }
{ lsearch -bisect $l $sNF }
{ lsearch -nocase $l $sNF }
{ lsearch -nocase -glob $l $sNF }
{ lsearch -nocase -exact $l $sNF }
{ lsearch -nocase -dictionary $l $sNF }
{ lsearch -nocase -exact -dictionary $l $sNF }
{ lsearch -nocase -sorted $l $sNF }
{ lsearch -nocase -bisect $l $sNF }
}
}
proc test-lsearch-nf-non-opti-fast {{reptime 1000}} {
_test_run -no-result $reptime {
# not-found, list with 5000 strings with ca. 50 chars elements:
setup { set str [join [lrepeat 13 "XXX"] /]; set sNF "$str/*"; set l [lrepeat 5000 $str]; llength $l }
{ lsearch -sorted -dictionary $l $sNF }
{ lsearch -bisect -dictionary $l $sNF }
{ lsearch -sorted -nocase -dictionary $l $sNF }
{ lsearch -bisect -nocase -dictionary $l $sNF }
}
}
proc test-lsearch-nf-non-opti-slow {{reptime 1000}} {
_test_run -no-result $reptime {
# not-found, list with 5000 strings with ca. 50 chars elements:
setup { set str [join [lrepeat 13 "XXX"] /]; set sNF "$str/*"; set l [lrepeat 5000 $str]; llength $l }
{ lsearch $l $sNF }
{ lsearch -glob $l $sNF }
{ lsearch -nocase $l $sNF }
{ lsearch -nocase -glob $l $sNF }
}
}
proc test-lseq {{reptime 1000}} {
_test_run $reptime {
setup { set i 0 }
{ lseq 10 }
{ lseq 0 count 10 }
{ lseq 0 count 10 by 1 }
{ lseq 0 9 }
{ lseq 0 to 9 }
{ lseq 0 9 1 }
{ lseq 0 to 9 by 1 }
}
}
proc test-lseq-expr {{reptime 1000}} {
_test_run $reptime {
setup { set i 0 }
{ lseq [expr {$i+10}] }
{ lseq {$i+10} }
{ lseq [expr {$i+0}] count [expr {$i+10}] }
{ lseq {$i+0} count {$i+10} }
{ lseq [expr {$i+0}] count [expr {$i+10}] by [expr {$i+1}] }
{ lseq {$i+0} count {$i+10} by {$i+1} }
{ lseq [expr {$i+0}] [expr {$i+9}] }
{ lseq {$i+0} {$i+9} }
{ lseq [expr {$i+0}] to [expr {$i+9}] }
{ lseq {$i+0} to {$i+9} }
{ lseq [expr {$i+0}] [expr {$i+9}] [expr {$i+1}] }
{ lseq {$i+0} {$i+9} {$i+1} }
{ lseq [expr {$i+0}] to [expr {$i+9}] by [expr {$i+1}] }
{ lseq {$i+0} to {$i+9} by {$i+1} }
}
}
proc test {{reptime 1000}} {
test-lsearch-regress $reptime
test-lsearch-nf-regress $reptime
test-lsearch-nf-non-opti-fast $reptime
test-lsearch-nf-non-opti-slow $reptime
test-lseq [expr {$reptime/2}]
test-lseq-expr [expr {$reptime/2}]
puts \n**OK**
}
}; # end of ::tclTestPerf-List
# ------------------------------------------------------------------------
# if calling direct:
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
array set in {-time 500}
array set in $argv
::tclTestPerf-List::test $in(-time)
}
|
Changes to tests-perf/listPerf.tcl.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
variable RunTimes
set RunTimes(command) 0.0
set RunTimes(total) 0.0
variable Options
array set Options {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
variable RunTimes
set RunTimes(command) 0.0
set RunTimes(total) 0.0
variable Options
array set Options {
--print-comments 0
--print-iterations 0
}
# Procs used for calibrating overhead
proc proc2args {a b} {}
proc proc3args {a b c} {}
proc print {s} {
puts $s
}
proc print_usage {} {
puts stderr "Usage: [file tail [info nameofexecutable]] $::argv0 \[options\] \[command ...\]"
puts stderr "\t--description DESC\tHuman readable description of test run"
puts stderr "\t--label LABEL\tA label used to identify test environment"
puts stderr "\t--print-comments\tPrint comment for each test"
puts stderr "\t--print-iterations\tPrint number of iterations run for each test"
}
proc setup {argv} {
variable Options
variable Lengths
while {[llength $argv]} {
set argv [lassign $argv arg]
switch -glob -- $arg {
--print-comments -
--print-iterations {
set Options($arg) 1
}
--label -
--description {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Options($arg) $val
}
--lengths {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Lengths $val
}
-- {
# Remaining will be passed back to the caller
break
}
--* {
puts stderr "Unknown option $arg"
print_usage
exit 1
}
default {
# Remaining will be passed back to the caller
set argv [linsert $argv 0 $arg]
break;
}
}
}
return $argv
}
proc format_timings {us iters} {
variable Options
if {!$Options(--print-iterations)} {
return "[format {%#10.4f} $us]"
}
return "[format {%#10.4f} $us] [format {%8d} $iters]"
}
proc measure {id script args} {
variable NullOverhead
variable RunTimes
variable Options
set opts(-overhead) ""
set opts(-runs) 5
while {[llength $args]} {
set args [lassign $args opt]
if {[llength $args] == 0} {
error "No argument supplied for $opt option. Test: $id"
}
set args [lassign $args val]
switch $opt {
-setup -
-cleanup -
-overhead -
-time -
-runs -
-reps {
set opts($opt) $val
}
default {
error "Unknown option $opt. Test: $id"
}
}
}
set timerate_args {}
if {[info exists opts(-time)]} {
lappend timerate_args $opts(-time)
}
if {[info exists opts(-reps)]} {
if {[info exists opts(-time)]} {
set timerate_args [list $opts(-time) $opts(-reps)]
} else {
# Force the default for first time option
set timerate_args [list 1000 $opts(-reps)]
}
} elseif {[info exists opts(-time)]} {
set timerate_args [list $opts(-time)]
}
if {[info exists opts(-setup)]} {
uplevel 1 $opts(-setup)
}
# Cache the empty overhead to prevent unnecessary delays. Note if you modify
# to cache other scripts, the cache key must be AFTER substituting the
# overhead script in the caller's context.
if {$opts(-overhead) eq ""} {
if {![info exists NullOverhead]} {
set NullOverhead [lindex [timerate {}] 0]
}
set overhead_us $NullOverhead
} else {
# The overhead measurements might use setup so we need to setup
# first and then cleanup in preparation for setting up again for
# the script to be measured
if {[info exists opts(-setup)]} {
uplevel 1 $opts(-setup)
}
set overhead_us [lindex [uplevel 1 [list timerate $opts(-overhead)]] 0]
if {[info exists opts(-cleanup)]} {
uplevel 1 $opts(-cleanup)
}
}
set timings {}
for {set i 0} {$i < $opts(-runs)} {incr i} {
if {[info exists opts(-setup)]} {
uplevel 1 $opts(-setup)
}
lappend timings [uplevel 1 [list timerate -overhead $overhead_us $script {*}$timerate_args]]
if {[info exists opts(-cleanup)]} {
uplevel 1 $opts(-cleanup)
}
}
set timings [lsort -real -index 0 $timings]
if {$opts(-runs) > 15} {
set ignore [expr {$opts(-runs)/8}]
} elseif {$opts(-runs) >= 5} {
set ignore 2
} else {
set ignore 0
}
# Ignore highest and lowest
set timings [lrange $timings 0 end-$ignore]
# Average it out
set us 0
set iters 0
foreach timing $timings {
set us [expr {$us + [lindex $timing 0]}]
set iters [expr {$iters + [lindex $timing 2]}]
}
set us [expr {$us/[llength $timings]}]
set iters [expr {$iters/[llength $timings]}]
set RunTimes(command) [expr {$RunTimes(command) + $us}]
print "P [format_timings $us $iters] $id"
}
proc comment {args} {
variable Options
if {$Options(--print-comments)} {
print "# [join $args { }]"
}
}
proc spanned_list {len} {
# Note - for small len, this will not create a spanned list
set delta [expr {$len/8}]
return [lrange [lrepeat [expr {$len+(2*$delta)}] a] $delta [expr {$delta+$len-1}]]
}
proc print_separator {command} {
comment [string repeat = 80]
comment Command: $command
}
oo::class create ListPerf {
constructor {args} {
my variable Opts
# Note default Opts can be overridden in construct as well as in measure
set Opts [dict merge {
-setup {
set L [lrepeat $len a]
set Lspan [perf::list::spanned_list $len]
} -cleanup {
unset -nocomplain L
unset -nocomplain Lspan
unset -nocomplain L2
}
} $args]
}
method measure {comment script locals args} {
my variable Opts
dict with locals {}
::perf::list::measure $comment $script {*}[dict merge $Opts $args]
}
method option {opt val} {
my variable Opts
dict set Opts $opt $val
}
method option_unset {opt} {
my variable Opts
unset -nocomplain Opts($opt)
}
}
proc linsert_describe {share_mode len at num iters} {
return "linsert L\[$len\] $share_mode $num elems $iters times at $at"
}
proc linsert_perf {} {
variable Lengths
print_separator linsert
ListPerf create perf -overhead {set L {}} -time 1000
# Note: Const indices take different path through bytecode than variable
# indices hence separate cases below
# Var case
foreach share_mode {shared unshared} {
set idx 0
if {$share_mode eq "shared"} {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe shared 0 "0 (var)" 1 1] {linsert $L $idx ""} -setup {set idx 0; set L {}}
} else {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe unshared 0 "0 (var)" 1 1] {linsert {} $idx ""} -setup {set idx 0}
}
foreach idx_str [list 0 1 mid end-1 end] {
foreach len $Lengths {
if {$idx_str eq "mid"} {
set idx [expr {$len/2}]
} else {
set idx $idx_str
}
# perf option -reps $reps
set reps 1000
if {$share_mode eq "shared"} {
comment Insert once to shared list with variable index
perf measure [linsert_describe shared $len "$idx (var)" 1 1] \
{linsert $L $idx x} [list len $len idx $idx] -overhead {} -reps 100000
comment Insert multiple times to shared list with variable index
perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] {
set L [linsert $L $idx X]
} [list len $len idx $idx] -reps $reps
comment Insert multiple items multiple times to shared list with variable index
perf measure [linsert_describe shared $len "$idx (var)" 5 $reps] {
set L [linsert $L $idx X X X X X]
} [list len $len idx $idx] -reps $reps
} else {
# NOTE : the Insert once case is left out for unshared lists
# because it requires re-init on every iteration resulting
# in a lot of measurement noise
comment Insert multiple times to unshared list with variable index
perf measure [linsert_describe unshared $len "$idx (var)" 1 $reps] {
set L [linsert $L[set L {}] $idx X]
} [list len $len idx $idx] -reps $reps
comment Insert multiple items multiple times to unshared list with variable index
perf measure [linsert_describe unshared $len "$idx (var)" 5 $reps] {
set L [linsert $L[set L {}] $idx X X X X X]
} [list len $len idx $idx] -reps $reps
}
}
}
}
# Const index
foreach share_mode {shared unshared} {
if {$share_mode eq "shared"} {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe shared 0 "0 (const)" 1 1] {linsert $L 0 ""} -setup {set L {}}
} else {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe unshared 0 "0 (const)" 1 1] {linsert {} 0 ""}
}
foreach idx_str [list 0 1 mid end end-1] {
foreach len $Lengths {
# Note end, end-1 explicitly calculated as otherwise they
# are not treated as const
if {$idx_str eq "mid"} {
set idx [expr {$len/2}]
} elseif {$idx_str eq "end"} {
set idx [expr {$len-1}]
} elseif {$idx_str eq "end-1"} {
set idx [expr {$len-2}]
} else {
set idx $idx_str
}
#perf option -reps $reps
set reps 100
if {$share_mode eq "shared"} {
comment Insert once to shared list with const index
perf measure [linsert_describe shared $len "$idx (const)" 1 1] \
"linsert \$L $idx x" [list len $len] -overhead {} -reps 10000
comment Insert multiple times to shared list with const index
perf measure [linsert_describe shared $len "$idx (const)" 1 $reps] \
"set L \[linsert \$L $idx X\]" [list len $len] -reps $reps
comment Insert multiple items multiple times to shared list with const index
perf measure [linsert_describe shared $len "$idx (const)" 5 $reps] \
"set L \[linsert \$L $idx X X X X X\]" [list len $len] -reps $reps
} else {
comment Insert multiple times to unshared list with const index
perf measure [linsert_describe unshared $len "$idx (const)" 1 $reps] \
"set L \[linsert \$L\[set L {}\] $idx X]" [list len $len] -reps $reps
comment Insert multiple items multiple times to unshared list with const index
perf measure [linsert_describe unshared $len "$idx (const)" 5 $reps] \
"set L \[linsert \$L\[set L {}\] $idx X X X X X]" [list len $len] -reps $reps
}
}
}
}
# Note: no span tests because the inserts above will themselves create
# spanned lists
perf destroy
}
proc list_describe {len text} {
return "list L\[$len\] $text"
}
proc list_perf {} {
variable Lengths
print_separator list
ListPerf create perf
foreach len $Lengths {
set s [join [lrepeat $len x]]
comment Create a list from a string
perf measure [list_describe $len "from a string"] {list $s} [list s $s len $len]
}
foreach len $Lengths {
comment Create a list from expansion - single list (special optimal case)
perf measure [list_describe $len "from a {*}list"] {list {*}$L} [list len $len]
comment Create a list from two lists - real test of expansion speed
perf measure [list_describe $len "from a {*}list {*}list"] {list {*}$L {*}$L} [list len [expr {$len/2}]]
}
perf destroy
}
proc lappend_describe {share_mode len num iters} {
return "lappend L\[$len\] $share_mode $num elems $iters times"
}
proc lappend_perf {} {
variable Lengths
print_separator lappend
ListPerf create perf -setup {set L [lrepeat [expr {$len/4}] x]}
# Shared
foreach len $Lengths {
comment Append to a shared list variable multiple times
perf measure [lappend_describe shared [expr {$len/2}] 1 $len] {
set L2 $L; # Make shared
lappend L x
} [list len $len] -reps $len -overhead {set L2 $L}
}
# Unshared
foreach len $Lengths {
comment Append to a unshared list variable multiple times
perf measure [lappend_describe unshared [expr {$len/2}] 1 $len] {
lappend L x
} [list len $len] -reps $len
}
# Span
foreach len $Lengths {
comment Append to a unshared-span list variable multiple times
perf measure [lappend_describe unshared-span [expr {$len/2}] 1 $len] {
lappend Lspan x
} [list len $len] -reps $len
}
perf destroy
}
proc lpop_describe {share_mode len at reps} {
return "lpop L\[$len\] $share_mode at $at $reps times"
}
proc lpop_perf {} {
variable Lengths
print_separator lpop
ListPerf create perf
# Shared
perf option -overhead {set L2 $L}
foreach len $Lengths {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
foreach idx {0 1 end-1 end} {
comment Pop element at position $idx from a shared list variable
perf measure [lpop_describe shared $len $idx $reps] {
set L2 $L
lpop L $idx
} [list len $len idx $idx] -reps $reps
}
}
# Unshared
perf option -overhead {}
foreach len $Lengths {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
foreach idx {0 1 end-1 end} {
comment Pop element at position $idx from an unshared list variable
perf measure [lpop_describe unshared $len $idx $reps] {
lpop L $idx
} [list len $len idx $idx] -reps $reps
}
}
perf destroy
# Nested
ListPerf create perf -setup {
set L [lrepeat $len [list a b]]
}
# Shared, nested index
perf option -overhead {set L2 $L; set L L2}
foreach len $Lengths {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
foreach idx {0 1 end-1 end} {
perf measure [lpop_describe shared $len "{$idx 0}" $reps] {
set L2 $L
lpop L $idx 0
set L $L2
} [list len $len idx $idx] -reps $reps
}
}
# TODO - Nested Unshared
# Not sure how to measure performance. When unshared there is no copy
# so deleting a nested index repeatedly is not feasible
perf destroy
}
proc lassign_describe {share_mode len num reps} {
return "lassign L\[$len\] $share_mode $num elems $reps times"
}
proc lassign_perf {} {
variable Lengths
print_separator lassign
ListPerf create perf
foreach share_mode {shared unshared} {
foreach len $Lengths {
if {$share_mode eq "shared"} {
set reps 1000
comment Reflexive lassign - shared
perf measure [lassign_describe shared $len 1 $reps] {
set L2 $L
set L2 [lassign $L2 v]
} [list len $len] -overhead {set L2 $L} -reps $reps
comment Reflexive lassign - shared, multiple
perf measure [lassign_describe shared $len 5 $reps] {
set L2 $L
set L2 [lassign $L2 a b c d e]
} [list len $len] -overhead {set L2 $L} -reps $reps
} else {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
comment Reflexive lassign - unshared
perf measure [lassign_describe unshared $len 1 $reps] {
set L [lassign $L v]
} [list len $len] -reps $reps
}
}
}
perf destroy
}
proc lrepeat_describe {len num} {
return "lrepeat L\[$len\] $num elems at a time"
}
proc lrepeat_perf {} {
variable Lengths
print_separator lrepeat
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Generate a list from a single repeated element
perf measure [lrepeat_describe $len 1] {
lrepeat $len a
} [list len $len]
comment Generate a list from multiple repeated elements
perf measure [lrepeat_describe $len 5] {
lrepeat $len a b c d e
} [list len $len]
}
perf destroy
}
proc lreverse_describe {share_mode len} {
return "lreverse L\[$len\] $share_mode"
}
proc lreverse_perf {} {
variable Lengths
print_separator lreverse
ListPerf create perf -reps 10000
foreach share_mode {shared unshared} {
foreach len $Lengths {
if {$share_mode eq "shared"} {
comment Reverse a shared list
perf measure [lreverse_describe shared $len] {
lreverse $L
} [list len $len]
if {$len > 100} {
comment Reverse a shared-span list
perf measure [lreverse_describe shared-span $len] {
lreverse $Lspan
} [list len $len]
}
} else {
comment Reverse a unshared list
perf measure [lreverse_describe unshared $len] {
set L [lreverse $L[set L {}]]
} [list len $len] -overhead {set L $L; set L {}}
if {$len >= 100} {
comment Reverse a unshared-span list
perf measure [lreverse_describe unshared-span $len] {
set Lspan [lreverse $Lspan[set Lspan {}]]
} [list len $len] -overhead {set Lspan $Lspan; set Lspan {}}
}
}
}
}
perf destroy
}
proc llength_describe {share_mode len} {
return "llength L\[$len\] $share_mode"
}
proc llength_perf {} {
variable Lengths
print_separator llength
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Length of a list
perf measure [llength_describe shared $len] {
llength $L
} [list len $len]
if {$len >= 100} {
comment Length of a span list
perf measure [llength_describe shared-span $len] {
llength $Lspan
} [list len $len]
}
}
perf destroy
}
proc lindex_describe {share_mode len at} {
return "lindex L\[$len\] $share_mode at $at"
}
proc lindex_perf {} {
variable Lengths
print_separator lindex
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Index into a list
set idx [expr {$len/2}]
perf measure [lindex_describe shared $len $idx] {
lindex $L $idx
} [list len $len idx $idx]
if {$len >= 100} {
comment Index into a span list
perf measure [lindex_describe shared-span $len $idx] {
lindex $Lspan $idx
} [list len $len idx $idx]
}
}
perf destroy
}
proc lrange_describe {share_mode len range} {
return "lrange L\[$len\] $share_mode range $range"
}
proc lrange_perf {} {
variable Lengths
print_separator lrange
ListPerf create perf -time 1000 -reps 100000
foreach share_mode {shared unshared} {
foreach len $Lengths {
set eighth [expr {$len/8}]
set ranges [list \
[list 0 0] [list 0 end-1] \
[list $eighth [expr {3*$eighth}]] \
[list $eighth [expr {7*$eighth}]] \
[list 1 end] [list end-1 end] \
]
foreach range $ranges {
comment Range $range in $share_mode list of length $len
if {$share_mode eq "shared"} {
perf measure [lrange_describe shared $len $range] \
"lrange \$L $range" [list len $len range $range]
} else {
perf measure [lrange_describe unshared $len $range] \
"lrange \[lrepeat \$len\ a] $range" \
[list len $len range $range] -overhead {lrepeat $len a}
}
}
if {$len >= 100} {
foreach range $ranges {
comment Range $range in ${share_mode}-span list of length $len
if {$share_mode eq "shared"} {
perf measure [lrange_describe shared-span $len $range] \
"lrange \$Lspan {*}$range" [list len $len range $range]
} else {
perf measure [lrange_describe unshared-span $len $range] \
"lrange \[perf::list::spanned_list \$len\] $range" \
[list len $len range $range] -overhead {perf::list::spanned_list $len}
}
}
}
}
}
perf destroy
}
proc lset_describe {share_mode len at} {
return "lset L\[$len\] $share_mode at $at"
}
proc lset_perf {} {
variable Lengths
print_separator lset
ListPerf create perf -reps 10000
# Shared
foreach share_mode {shared unshared} {
foreach len $Lengths {
foreach idx {0 1 end-1 end end+1} {
comment lset at position $idx in a $share_mode list variable
if {$share_mode eq "shared"} {
perf measure [lset_describe shared $len $idx] {
set L2 $L
lset L $idx X
} [list len $len idx $idx] -overhead {set L2 $L}
} else {
perf measure [lset_describe unshared $len $idx] {
lset L $idx X
} [list len $len idx $idx]
}
}
}
}
perf destroy
# Nested
ListPerf create perf -setup {
set L [lrepeat $len [list a b]]
}
foreach share_mode {shared unshared} {
foreach len $Lengths {
foreach idx {0 1 end-1 end} {
comment lset at position $idx in a $share_mode list variable
if {$share_mode eq "shared"} {
perf measure [lset_describe shared $len "{$idx 0}"] {
set L2 $L
lset L $idx 0 X
} [list len $len idx $idx] -overhead {set L2 $L}
} else {
perf measure [lset_describe unshared $len "{$idx 0}"] {
lset L $idx 0 {X Y}
} [list len $len idx $idx]
}
}
}
}
perf destroy
}
proc lremove_describe {share_mode len at nremoved} {
return "lremove L\[$len\] $share_mode $nremoved elements at $at"
}
proc lremove_perf {} {
variable Lengths
print_separator lremove
ListPerf create perf -reps 10000
foreach share_mode {shared unshared} {
foreach len $Lengths {
foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Remove one element from shared list
perf measure [lremove_describe shared $len $idx 1] \
{lremove $L $idx} [list len $len idx $idx]
} else {
comment Remove one element from unshared list
set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}]
perf measure [lremove_describe unshared $len $idx 1] \
{set L [lremove $L[set L {}] $idx]} [list len $len idx $idx] \
-overhead {set L $L; set L {}} -reps $reps
}
}
if {$share_mode eq "shared"} {
comment Remove multiple elements from shared list
perf measure [lremove_describe shared $len [list 0 1 [expr {$len/2}] end-1 end] 5] {
lremove $L 0 1 [expr {$len/2}] end-1 end
} [list len $len]
}
}
# Span
foreach len $Lengths {
foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Remove one element from shared-span list
perf measure [lremove_describe shared-span $len $idx 1] \
{lremove $Lspan $idx} [list len $len idx $idx]
} else {
comment Remove one element from unshared-span list
set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}]
perf measure [lremove_describe unshared-span $len $idx 1] \
{set Lspan [lremove $Lspan[set Lspan {}] $idx]} [list len $len idx $idx] \
-overhead {set Lspan $Lspan; set Lspan {}} -reps $reps
}
}
if {$share_mode eq "shared"} {
comment Remove multiple elements from shared-span list
perf measure [lremove_describe shared-span $len [list 0 1 [expr {$len/2}] end-1 end] 5] {
lremove $Lspan 0 1 [expr {$len/2}] end-1 end
} [list len $len]
}
}
}
perf destroy
}
proc lreplace_describe {share_mode len first last ninsert {times 1}} {
if {$last < $first} {
return "lreplace L\[$len\] $share_mode 0 ($first:$last) elems at $first with $ninsert elems $times times."
}
return "lreplace L\[$len\] $share_mode $first:$last with $ninsert elems $times times."
}
proc lreplace_perf {} {
variable Lengths
print_separator lreplace
set default_reps 10000
ListPerf create perf -reps $default_reps
foreach share_mode {shared unshared} {
# Insert only
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach first [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Insert one to shared list
perf measure [lreplace_describe shared $len $first -1 1] {
lreplace $L $first -1 x
} [list len $len first $first]
comment Insert multiple to shared list
perf measure [lreplace_describe shared $len $first -1 10] {
lreplace $L $first -1 X X X X X X X X X X
} [list len $len first $first]
comment Insert one to shared list repeatedly
perf measure [lreplace_describe shared $len $first -1 1 $reps] {
set L [lreplace $L $first -1 x]
} [list len $len first $first] -reps $reps
comment Insert multiple to shared list repeatedly
perf measure [lreplace_describe shared $len $first -1 10 $reps] {
set L [lreplace $L $first -1 X X X X X X X X X X]
} [list len $len first $first] -reps $reps
} else {
comment Insert one to unshared list
perf measure [lreplace_describe unshared $len $first -1 1] {
set L [lreplace $L[set L {}] $first -1 x]
} [list len $len first $first] -overhead {
set L $L; set L {}
} -reps $reps
comment Insert multiple to unshared list
perf measure [lreplace_describe unshared $len $first -1 10] {
set L [lreplace $L[set L {}] $first -1 X X X X X X X X X X]
} [list len $len first $first] -overhead {
set L $L; set L {}
} -reps $reps
}
}
}
# Delete only
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach first [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Delete one from shared list
perf measure [lreplace_describe shared $len $first $first 0] {
lreplace $L $first $first
} [list len $len first $first]
} else {
comment Delete one from unshared list
perf measure [lreplace_describe unshared $len $first $first 0] {
set L [lreplace $L[set L {}] $first $first x]
} [list len $len first $first] -overhead {
set L $L; set L {}
} -reps $reps
}
}
}
# Insert + delete
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] {
lassign $range first last
if {$share_mode eq "shared"} {
comment Insertions more than deletions from shared list
perf measure [lreplace_describe shared $len $first $last 3] {
lreplace $L $first $last X Y Z
} [list len $len first $first last $last]
comment Insertions same as deletions from shared list
perf measure [lreplace_describe shared $len $first $last 2] {
lreplace $L $first $last X Y
} [list len $len first $first last $last]
comment Insertions fewer than deletions from shared list
perf measure [lreplace_describe shared $len $first $last 1] {
lreplace $L $first $last X
} [list len $len first $first last $last]
} else {
comment Insertions more than deletions from unshared list
perf measure [lreplace_describe unshared $len $first $last 3] {
set L [lreplace $L[set L {}] $first $last X Y Z]
} [list len $len first $first last $last] -overhead {
set L $L; set L {}
} -reps $reps
comment Insertions same as deletions from unshared list
perf measure [lreplace_describe unshared $len $first $last 2] {
set L [lreplace $L[set L {}] $first $last X Y ]
} [list len $len first $first last $last] -overhead {
set L $L; set L {}
} -reps $reps
comment Insertions fewer than deletions from unshared list
perf measure [lreplace_describe unshared $len $first $last 1] {
set L [lreplace $L[set L {}] $first $last X]
} [list len $len first $first last $last] -overhead {
set L $L; set L {}
} -reps $reps
}
}
}
# Spanned Insert + delete
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] {
lassign $range first last
if {$share_mode eq "shared"} {
comment Insertions more than deletions from shared-span list
perf measure [lreplace_describe shared-span $len $first $last 3] {
lreplace $Lspan $first $last X Y Z
} [list len $len first $first last $last]
comment Insertions same as deletions from shared-span list
perf measure [lreplace_describe shared-span $len $first $last 2] {
lreplace $Lspan $first $last X Y
} [list len $len first $first last $last]
comment Insertions fewer than deletions from shared-span list
perf measure [lreplace_describe shared-span $len $first $last 1] {
lreplace $Lspan $first $last X
} [list len $len first $first last $last]
} else {
comment Insertions more than deletions from unshared-span list
perf measure [lreplace_describe unshared-span $len $first $last 3] {
set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y Z]
} [list len $len first $first last $last] -overhead {
set Lspan $Lspan; set Lspan {}
} -reps $reps
comment Insertions same as deletions from unshared-span list
perf measure [lreplace_describe unshared-span $len $first $last 2] {
set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y ]
} [list len $len first $first last $last] -overhead {
set Lspan $Lspan; set Lspan {}
} -reps $reps
comment Insertions fewer than deletions from unshared-span list
perf measure [lreplace_describe unshared-span $len $first $last 1] {
set Lspan [lreplace $Lspan[set Lspan {}] $first $last X]
} [list len $len first $first last $last] -overhead {
set Lspan $Lspan; set Lspan {}
} -reps $reps
}
}
}
}
perf destroy
}
proc split_describe {len} {
return "split L\[$len\]"
}
proc split_perf {} {
variable Lengths
print_separator split
ListPerf create perf -setup {set S [string repeat "x " $len]}
foreach len $Lengths {
comment Split a string
perf measure [split_describe $len] {
split $S " "
} [list len $len]
}
}
proc join_describe {share_mode len} {
return "join L\[$len\] $share_mode"
}
proc join_perf {} {
variable Lengths
print_separator join
ListPerf create perf -reps 10000
foreach len $Lengths {
comment Join a list
perf measure [join_describe shared $len] {
join $L
} [list len $len]
}
foreach len $Lengths {
comment Join a spanned list
perf measure [join_describe shared-span $len] {
join $Lspan
} [list len $len]
}
perf destroy
}
proc lsearch_describe {share_mode len} {
return "lsearch L\[$len\] $share_mode"
}
proc lsearch_perf {} {
variable Lengths
print_separator lsearch
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Search a list
perf measure [lsearch_describe shared $len] {
lsearch $L needle
} [list len $len]
}
foreach len $Lengths {
comment Search a spanned list
perf measure [lsearch_describe shared-span $len] {
lsearch $Lspan needle
} [list len $len]
}
perf destroy
}
proc foreach_describe {share_mode len} {
return "foreach L\[$len\] $share_mode"
}
proc foreach_perf {} {
variable Lengths
print_separator foreach
ListPerf create perf -reps 10000
foreach len $Lengths {
comment Iterate through a list
perf measure [foreach_describe shared $len] {
foreach e $L {}
} [list len $len]
}
foreach len $Lengths {
comment Iterate a spanned list
perf measure [foreach_describe shared-span $len] {
foreach e $Lspan {}
} [list len $len]
}
perf destroy
}
proc lmap_describe {share_mode len} {
return "lmap L\[$len\] $share_mode"
}
proc lmap_perf {} {
variable Lengths
print_separator lmap
ListPerf create perf -reps 10000
foreach len $Lengths {
comment Iterate through a list
perf measure [lmap_describe shared $len] {
lmap e $L {}
} [list len $len]
}
foreach len $Lengths {
comment Iterate a spanned list
perf measure [lmap_describe shared-span $len] {
lmap e $Lspan {}
} [list len $len]
}
perf destroy
}
proc get_sort_sample {{spanned 0}} {
variable perfScript
variable sortSampleText
if {![info exists sortSampleText]} {
set fd [open $perfScript]
set sortSampleText [split [read $fd] ""]
close $fd
}
set sortSampleText [string range $sortSampleText 0 9999]
# NOTE: do NOT cache list result in a variable as we need it unshared
if {$spanned} {
return [lrange [split $sortSampleText ""] 1 end-1]
} else {
return [split $sortSampleText ""]
}
}
proc lsort_describe {share_mode len} {
return "lsort L\[$len] $share_mode"
}
proc lsort_perf {} {
print_separator lsort
ListPerf create perf -setup {}
comment Sort a shared list
perf measure [lsort_describe shared [llength [perf::list::get_sort_sample]]] {
lsort $L
} {} -setup {set L [perf::list::get_sort_sample]}
comment Sort a shared-span list
perf measure [lsort_describe shared-span [llength [perf::list::get_sort_sample 1]]] {
lsort $L
} {} -setup {set L [perf::list::get_sort_sample 1]}
comment Sort an unshared list
perf measure [lsort_describe unshared [llength [perf::list::get_sort_sample]]] {
lsort [perf::list::get_sort_sample]
} {} -overhead {perf::list::get_sort_sample}
comment Sort an unshared-span list
perf measure [lsort_describe unshared-span [llength [perf::list::get_sort_sample 1]]] {
lsort [perf::list::get_sort_sample 1]
} {} -overhead {perf::list::get_sort_sample 1}
perf destroy
}
proc concat_describe {canonicality len elemlen} {
return "concat L\[$len\] $canonicality with elements of length $elemlen"
}
proc concat_perf {} {
variable Lengths
print_separator concat
ListPerf create perf -reps 100000
foreach len $Lengths {
foreach elemlen {1 100} {
comment Pure lists (no string representation)
perf measure [concat_describe "pure lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrepeat $len [string repeat a $elemlen]]
}
comment Canonical lists (with string representation)
perf measure [concat_describe "canonical lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrepeat $len [string repeat a $elemlen]]
append x x $L; # Generate string while keeping internal rep list
unset x
}
comment Non-canonical lists
perf measure [concat_describe "non-canonical lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [string repeat "[string repeat a $elemlen] " $len]
llength $L
}
}
}
# Span version
foreach len $Lengths {
foreach elemlen {1 100} {
comment Pure span lists (no string representation)
perf measure [concat_describe "pure spanned lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1]
}
comment Canonical span lists (with string representation)
perf measure [concat_describe "canonical spanned lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1]
append x x $L; # Generate string while keeping internal rep list
unset x
}
}
}
perf destroy
}
proc test {} {
variable RunTimes
variable Options
set selections [perf::list::setup $::argv]
if {[llength $selections] == 0} {
set commands [info commands ::perf::list::*_perf]
} else {
set commands [lmap sel $selections {
if {$sel eq "help"} {
print_usage
exit 0
}
set cmd ::perf::list::${sel}_perf
if {$cmd ni [info commands ::perf::list::*_perf]} {
puts stderr "Error: command $sel is not known or supported. Skipping."
continue
}
set cmd
}]
}
comment Setting up
timerate -calibrate {}
if {[info exists Options(--label)]} {
print "L $Options(--label)"
}
print "V [info patchlevel]"
print "E [info nameofexecutable]"
if {[info exists Options(--description)]} {
print "D $Options(--description)"
}
set twapi_keys {-privatebytes -workingset -workingsetpeak}
if {[info commands ::twapi::get_process_memory_info] ne ""} {
set twapi_vm_pre [::twapi::get_process_memory_info]
}
foreach cmd [lsort -dictionary $commands] {
set RunTimes(command) 0.0
$cmd
set RunTimes(total) [expr {$RunTimes(total)+$RunTimes(command)}]
print "P [format_timings $RunTimes(command) 1] [string range $cmd 14 end-5] total run time"
}
# Print total runtime in same format as timerate output
print "P [format_timings $RunTimes(total) 1] Total run time"
if {[info exists twapi_vm_pre]} {
set twapi_vm_post [::twapi::get_process_memory_info]
set MB 1048576.0
foreach key $twapi_keys {
set pre [expr {[dict get $twapi_vm_pre $key]/$MB}]
set post [expr {[dict get $twapi_vm_post $key]/$MB}]
print "P [format_timings $pre 1] Memory (MB) $key pre-test"
print "P [format_timings $post 1] Memory (MB) $key post-test"
print "P [format_timings [expr {$post-$pre}] 1] Memory (MB) delta $key"
}
}
if {[info commands memory] ne ""} {
foreach line [split [memory info] \n] {
if {$line eq ""} continue
set line [split $line]
set val [expr {[lindex $line end]/1000.0}]
set line [string trim [join [lrange $line 0 end-1]]]
print "P [format_timings $val 1] memdbg $line (in thousands)"
}
print "# Allocations not freed on exit written to the lost-memory.tmp file."
print "# These will have to be manually compared."
# env TCL_FINALIZE_ON_EXIT must be set to 1 for this.
# DO NOT SET HERE - set ::env(TCL_FINALIZE_ON_EXIT) 1
# Must be set in environment before starting tclsh else bogus results
if {[info exists Options(--label)]} {
set dump_file list-memory-$Options(--label).memdmp
} else {
set dump_file list-memory-[pid].memdmp
}
memory onexit $dump_file
}
}
}
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
::perf::list::test
}
|
Changes to tests-perf/test-performance.tcl.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
break
}
if {[string is boolean -strict $_($o)]} {
set _($o) [expr {! $_($o)}]
set args [lrange $args 1 end]
} else {
if {[llength $args] <= 2} {
| | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
break
}
if {[string is boolean -strict $_($o)]} {
set _($o) [expr {! $_($o)}]
set args [lrange $args 1 end]
} else {
if {[llength $args] <= 2} {
return -code error "value expected for option $o"
}
set _($o) [lindex $args 1]
set args [lrange $args 2 end]
}
}
unset -nocomplain o
if {[llength $args] < 2 || [llength $args] > 3} {
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
# process measurement:
foreach _(c) [_test_get_commands $lst] {
{*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
if {[regexp {^\s*\#} $_(c)]} continue
if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
set _(c) [lindex $_(c) 1]
if {$_(-uplevel)} {
| | | | 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 |
# process measurement:
foreach _(c) [_test_get_commands $lst] {
{*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
if {[regexp {^\s*\#} $_(c)]} continue
if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
set _(c) [lindex $_(c) 1]
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
{*}$_(outcmd) [if 1 $_(c)]
continue
}
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
set _(ittime) $_(reptime)
# if output result (and not once):
if {!$_(-no-result)} {
set _(r) [if 1 $_(c)]
if {$_(-convert-result) ne ""} { set _(r) [if 1 $_(-convert-result)] }
{*}$_(outcmd) $_(r)
if {[llength $_(ittime)] > 1} { # decrement max-count
lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
}
}
{*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
lappend _(itm) $_(m)
{*}$_(outcmd) ""
}
if {$_(-from-run)} {
_test_out_total
}
}
}; # end of namespace ::tclTestPerf
|
Changes to tests/aaa_exit.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test exit-1.1 {normal, quick exit} {
| | | | | | | | | | | | | | | | | | | | 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 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test exit-1.1 {normal, quick exit} {
set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r]
set aft [after 1000 {set done "Quick exit hangs !!!"}]
fileevent $f readable {after cancel $aft;set done OK}
vwait done
if {$done != "OK"} {
fconfigure $f -blocking 0
close $f
} else {
if {[catch {close $f} err]} {
set done "Quick exit misbehaves: $err"
}
}
set done
} OK
test exit-1.2 {full-finalized exit} {
set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r]
set aft [after 1000 {set done "Full-finalized exit hangs !!!"}]
fileevent $f readable {after cancel $aft;set done OK}
vwait done
if {$done != "OK"} {
fconfigure $f -blocking 0
close $f
} else {
if {[catch {close $f} err]} {
set done "Full-finalized exit misbehaves: $err"
}
}
set done
} OK
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/all.tcl.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package prefer latest package require tcltest 2.5 namespace import ::tcltest::* | < | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package prefer latest
package require tcltest 2.5
namespace import ::tcltest::*
configure -testdir [file normalize [file dirname [info script]]] {*}$argv
if {[singleProcess]} {
interp debug {} -frame 1
}
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
unset -nocomplain env(ERROR_ON_FAILURES)
|
| ︙ | ︙ |
Changes to tests/assemble.test.
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
eval [list assemble {push hello}]
}
-result hello
}
test assemble-6.4 {push4} {
-body {
proc x {} "
| | | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
eval [list assemble {push hello}]
}
-result hello
}
test assemble-6.4 {push4} {
-body {
proc x {} "
[fillTables]
assemble {push hello}
"
x
}
-cleanup {
rename x {}
}
-result hello
}
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
test assemble-7.43 {uplus} {
-body {
assemble {
push NaN; uplus
}
}
-returnCodes error
| | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
test assemble-7.43 {uplus} {
-body {
assemble {
push NaN; uplus
}
}
-returnCodes error
-result {cannot use non-numeric floating-point value "NaN" as operand of "+"}
}
test assemble-7.43.1 {tryCvtToNumeric} {
-body {
assemble {
push NaN; tryCvtToNumeric
}
}
|
| ︙ | ︙ | |||
862 863 864 865 866 867 868 |
-result able
-cleanup {rename x {}}
}
test assemble-8.7 {load4} {
-body {
proc x {a} "
[fillTables]
| | | | | 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 |
-result able
-cleanup {rename x {}}
}
test assemble-8.7 {load4} {
-body {
proc x {a} "
[fillTables]
set b \$a
assemble {load b}
"
x able
}
-result able
-cleanup {rename x {}}
}
test assemble-8.8 {loadArray1} {
-body {
|
| ︙ | ︙ | |||
887 888 889 890 891 892 893 |
}
-result charlie
-cleanup {rename x {}}
}
test assemble-8.9 {loadArray4} {
-body "
proc x {} {
| | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 |
}
-result charlie
-cleanup {rename x {}}
}
test assemble-8.9 {loadArray4} {
-body "
proc x {} {
[fillTables]
set able(baker) charlie
assemble {
push baker
loadArray able
}
}
x
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.11 {append4} {
-body {
proc x {} "
| | | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.11 {append4} {
-body {
proc x {} "
[fillTables]
set y {hello, }
assemble {
push world; append y
}
"
x
}
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.13 {appendArray4} {
-body {
proc x {} "
| | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.13 {appendArray4} {
-body {
proc x {} "
[fillTables]
set y(z) {hello, }
assemble {
push z; push world; appendArray y
}
"
x
}
|
| ︙ | ︙ | |||
969 970 971 972 973 974 975 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.15 {lappend4} {
-body {
proc x {} "
| | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.15 {lappend4} {
-body {
proc x {} "
[fillTables]
set y {hello,}
assemble {
push world; lappend y
}
"
x
}
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.17 {lappendArray4} {
-body {
proc x {} "
| | | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 |
}
-result {hello, world}
-cleanup {rename x {}}
}
test assemble-8.17 {lappendArray4} {
-body {
proc x {} "
[fillTables]
set y(z) {hello,}
assemble {
push z; push world; lappendArray y
}
"
x
}
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
}
-result {test}
-cleanup {rename x {}}
}
test assemble-8.19 {store4} {
-body {
proc x {} "
| | | | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 |
}
-result {test}
-cleanup {rename x {}}
}
test assemble-8.19 {store4} {
-body {
proc x {} "
[fillTables]
assemble {
push test; store y
}
set y
"
x
}
-result test
-cleanup {rename x {}}
}
test assemble-8.20 {storeArray1} {
|
| ︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 |
}
-result test
-cleanup {rename x {}}
}
test assemble-8.21 {storeArray4} {
-body {
proc x {} "
| | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
}
-result test
-cleanup {rename x {}}
}
test assemble-8.21 {storeArray4} {
-body {
proc x {} "
[fillTables]
assemble {
push z; push test; storeArray y
}
"
x
}
-result test
|
| ︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 |
-result 8
-cleanup {rename x {}}
}
test assemble-12.6 {incr, stupid stack restriction} {
-body {
proc x {} "
[fillTables]
| | | | | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
-result 8
-cleanup {rename x {}}
}
test assemble-12.6 {incr, stupid stack restriction} {
-body {
proc x {} "
[fillTables]
set y 5
assemble {push 3; incr y}
"
list [catch {x} result] $result $errorCode
}
-result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
-cleanup {unset result; rename x {}}
}
# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm
|
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
-result 8
-cleanup {rename x {}}
}
test assemble-13.9 {incrImm, stupid stack restriction} {
-body {
proc x {} "
[fillTables]
| | | | | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
-result 8
-cleanup {rename x {}}
}
test assemble-13.9 {incrImm, stupid stack restriction} {
-body {
proc x {} "
[fillTables]
set y 5
assemble {incrImm y 3}
"
list [catch {x} result] $result $errorCode
}
-result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
-cleanup {unset result; rename x {}}
}
# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm)
|
| ︙ | ︙ |
Changes to tests/autoMkindex.test.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
proc pub_one {args} {return "one: $args"}
proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}
namespace eval buried {
namespace eval under {
| | | | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
proc pub_one {args} {return "one: $args"}
proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}
namespace eval buried {
namespace eval under {
proc neath {args} {return "neath: $args"}
}
namespace eval ::buried {
proc relative {args} {return "relative: $args"}
proc ::top {args} {return "top: $args"}
proc ::buried::explicit {args} {return "explicit: $args"}
}
}
# With proper hooks, we should be able to support other commands that create
# procedures
proc buried::myproc {name body args} {
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
file delete tclIndex
file exists tclIndex
} {0}
test autoMkindex-1.2 {build tclIndex based on a test file} {
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} {1}
| | | | | | | | | | | | | | | | | 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 |
file delete tclIndex
file exists tclIndex
} {0}
test autoMkindex-1.2 {build tclIndex based on a test file} {
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} {1}
set element "{source -encoding utf-8 [file join . autoMkindex.tcl]}"
test autoMkindex-1.3 {examine tclIndex} -setup {
file delete tclIndex
} -body {
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
source tclIndex
set ::result ""
foreach elem [lsort [array names auto_index]] {
lappend ::result [list $elem $auto_index($elem)]
}
}
return $result
} -cleanup {
namespace delete tcl_autoMkindex_tmp
} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}"
test autoMkindex-2.1 {commands on the autoload path can be imported} -setup {
file delete tclIndex
interp create child
} -body {
auto_mkindex . autoMkindex.tcl
child eval {
namespace eval blt {}
set auto_path [linsert $auto_path 0 .]
set info [list [catch {namespace import buried::*} result] $result]
foreach name [lsort [info commands pub_*]] {
lappend info $name [namespace origin $name]
}
return $info
}
} -cleanup {
interp delete child
} -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"
# Test auto_mkindex hooks
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
test autoMkindex-3.2 {auto_mkindex_parser::command} -setup {
file delete tclIndex
} -body {
auto_mkindex_parser::command buried::myproc {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])] \
| | | | | | | | | | | | | | | | | | 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 |
test autoMkindex-3.2 {auto_mkindex_parser::command} -setup {
file delete tclIndex
} -body {
auto_mkindex_parser::command buried::myproc {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])] \
" \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
}
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
source tclIndex
set ::result ""
foreach elem [lsort [array names auto_index]] {
lappend ::result [list $elem $auto_index($elem)]
}
return $::result
}
} -cleanup {
namespace delete tcl_autoMkindex_tmp
# Reset initCommands to avoid trashing other tests
AutoMkindexTestReset
} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}"
test autoMkindex-3.3 {auto_mkindex_parser::command} -setup {
file delete tclIndex
} -constraints {knownBug} -body {
auto_mkindex_parser::command {buried::my proc} {name args} {
variable index
variable scriptFile
puts "my proc $name"
append index [list set auto_index([fullname $name])] \
" \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
}
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
source tclIndex
set ::result ""
foreach elem [lsort [array names auto_index]] {
lappend ::result [list $elem $auto_index($elem)]
}
}
list [lsearch -inline $::result *mycmd4*] \
[lsearch -inline $::result *mycmd5*] \
[lsearch -inline $::result *mycmd6*]
} -cleanup {
namespace delete tcl_autoMkindex_tmp
# Reset initCommands to avoid trashing other tests
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
if {[string match {set auto_index*} $r]} {
lappend dat $r
}
}
set result [lsort $dat]
close $f
set result
| | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
if {[string match {set auto_index*} $r]} {
lappend dat $r
}
}
set result [lsort $dat]
close $f
set result
} {{set auto_index(::wok::commands) [list source -encoding utf-8 [file join $dir ensemblecommands.tcl]]} {set auto_index(::wok::vars) [list source -encoding utf-8 [file join $dir ensemblecommands.tcl]]} {set auto_index(wok) [list source -encoding utf-8 [file join $dir ensemblecommands.tcl]]}}
removeFile ensemblecommands.tcl
test autoMkindex-4.1 {platform independent source commands} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
package provide football 1.0
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
auto_mkindex . pkg/samename.tcl
set f [open tclIndex r]
lsort [lrange [split [string trim [read $f]] "\n"] end-1 end]
} -cleanup {
catch {close $f}
removeFile [file join pkg samename.tcl]
removeDirectory pkg
| | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
auto_mkindex . pkg/samename.tcl
set f [open tclIndex r]
lsort [lrange [split [string trim [read $f]] "\n"] end-1 end]
} -cleanup {
catch {close $f}
removeFile [file join pkg samename.tcl]
removeDirectory pkg
} -result {{set auto_index(::college::team) [list source -encoding utf-8 [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source -encoding utf-8 [file join $dir pkg samename.tcl]]}}
test autoMkindex-5.1 {escape magic tcl chars in general code} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
set dollar2 \
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
auto_mkindex . pkg/magicchar.tcl
set f [open tclIndex r]
lindex [split [string trim [read $f]] "\n"] end
} -cleanup {
catch {close $f}
removeFile [file join pkg magicchar.tcl]
removeDirectory pkg
| | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
auto_mkindex . pkg/magicchar.tcl
set f [open tclIndex r]
lindex [split [string trim [read $f]] "\n"] end
} -cleanup {
catch {close $f}
removeFile [file join pkg magicchar.tcl]
removeDirectory pkg
} -result {set auto_index(testProc) [list source -encoding utf-8 [file join $dir pkg magicchar.tcl]]}
test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]
set result {}
|
| ︙ | ︙ |
Changes to tests/basic.test.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
catch {rename cmd ""}
unset -nocomplain x
test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
| | | | | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
catch {rename cmd ""}
unset -nocomplain x
test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_basic {
proc p {} {
return [namespace current]
}
}
}
list [interp eval test_interp {test_ns_basic::p}] \
[interp delete test_interp]
} {::test_ns_basic {}}
test basic-2.1 {TclHideUnsafeCommands} {emptyTest} {
} {}
test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
} {}
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
} {}
test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
} {}
test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_basic {
namespace export p
proc p {} {
return [namespace current]
}
}
namespace eval test_ns_2 {
namespace import ::test_ns_basic::p
variable v 27
proc q {} {
variable v
return "[p] $v"
}
}
}
list [interp eval test_interp {test_ns_2::q}] \
[interp eval test_interp {namespace delete ::}] \
[catch {interp eval test_interp {set a 123}} msg] $msg \
[interp delete test_interp]
} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}
test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
proc p {} {
return 27
}
}
interp alias {} localP test_interp p
list [interp eval test_interp {p}] \
[localP] \
[test_interp hide p] \
[catch {localP} msg] $msg \
[interp delete test_interp] \
[catch {localP} msg] $msg
} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
# NB: More tests about hide/expose are found in interp.test
test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_basic {
proc p {} {
return [namespace current]
}
}
}
list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
[catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
[interp delete test_interp]
} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}}
test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
proc cmd {} { ;# note that this is global
return [namespace current]
}
namespace eval test_ns_basic {
proc hideCmd {} {
interp hide {} cmd
}
proc exposeCmd {} {
interp expose {} cmd
}
proc callCmd {} {
cmd
}
}
list [test_ns_basic::callCmd] \
[test_ns_basic::hideCmd] \
[catch {cmd} msg] $msg \
[test_ns_basic::exposeCmd] \
[test_ns_basic::callCmd] \
[namespace delete test_ns_basic]
} {:: {} 1 {invalid command name "cmd"} {} :: {}}
test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and cannot go to another namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
proc cmd {} { ;# note that this is global
return [namespace current]
}
namespace eval test_ns_basic {
proc hideCmd {} {
interp hide {} cmd
}
proc exposeCmdFailing {} {
interp expose {} cmd ::test_ns_basic::newCmd
}
proc exposeCmdWorkAround {} {
interp expose {} cmd;
rename cmd ::test_ns_basic::newCmd;
}
proc callCmd {} {
cmd
}
}
list [test_ns_basic::callCmd] \
[test_ns_basic::hideCmd] \
[catch {test_ns_basic::exposeCmdFailing} msg] $msg \
[test_ns_basic::exposeCmdWorkAround] \
[test_ns_basic::newCmd] \
[namespace delete test_ns_basic]
} {:: {} 1 {cannot expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
catch {rename p ""}
catch {rename cmd ""}
proc p {} {
cmd
}
proc cmd {} {
return 42
}
list [p] \
[interp hide {} cmd] \
[proc cmd {} {return Hello}] \
[cmd] \
[rename cmd ""] \
[interp expose {} cmd] \
[p]
} {42 {} {} Hello {} {} 42}
test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [testcreatecommand create] \
[test_ns_basic::createdcommand] \
[testcreatecommand delete]
} {{} {CreatedCommandProc in ::test_ns_basic} {}}
test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename value:at: ""}
list [testcreatecommand create2] \
[value:at:] \
[testcreatecommand delete2]
} {{} {CreatedCommandProc2 in ::} {}}
test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_basic {}
proc test_ns_basic::cmd {} { ;# proc requires that ns already exist
return [namespace current]
}
list [test_ns_basic::cmd] \
[namespace delete test_ns_basic]
} {::test_ns_basic {}}
test basic-15.2 {Tcl_CreateObjCommand, Bug 0e4d88b650} -setup {
proc deleter {ns args} {
namespace delete $ns
}
namespace eval n {
proc p {} {}
}
trace add command n::p delete [list [namespace which deleter] [namespace current]::n]
} -body {
proc n::p {} {}
} -cleanup {
namespace delete n
rename deleter {}
}
test basic-16.1 {InvokeStringCommand} {emptyTest} {
} {}
test basic-17.1 {InvokeObjCommand} {emptyTest} {
} {}
test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename cmd ""}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
}
}
list [test_ns_basic::p] \
[rename test_ns_basic::p test_ns_basic::q] \
[test_ns_basic::q]
} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
test basic-18.2 {TclRenameCommand, existing cmd must be found} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
} {1 {can't rename "test_ns_basic::p": command doesn't exist}}
test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
}
}
list [info commands test_ns_basic::*] \
[rename test_ns_basic::p ""] \
[info commands test_ns_basic::*]
} {::test_ns_basic::p {} {}}
test basic-18.4 {TclRenameCommand, bad new name} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
}
}
rename test_ns_basic::p :::george::martha
} {}
test basic-18.5 {TclRenameCommand, new name must not already exist} -setup {
if {![llength [info commands :::george::martha]]} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
}
}
rename test_ns_basic::p :::george::martha
}
} -body {
namespace eval test_ns_basic {
proc q {} {
return 42
}
}
list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
} -result {1 {can't rename to ":::george::martha": command already exists}}
test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
proc p {} {
return "p in [namespace current]"
}
proc q {} {
return "q in [namespace current]"
}
namespace eval test_ns_basic {
proc callP {} {
p
}
}
list [test_ns_basic::callP] \
[rename q test_ns_basic::p] \
[test_ns_basic::callP]
} {{p in ::} {} {q in ::test_ns_basic}}
test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
} {}
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
unset -nocomplain x
set x [namespace eval test_ns_basic::test_ns_basic2 {
# the following creates a cmd in the global namespace
testcmdtoken create p
}]
list [testcmdtoken name $x] \
[rename ::p q] \
[testcmdtoken name $x]
} {{p ::p} {} {q ::q}}
test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
catch {rename q ""}
set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
list [testcmdtoken name $x] \
[rename test_ns_basic::test_ns_basic2::p q] \
[testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken {
catch {rename \# ""}
set x [testcmdtoken create \#]
return [testcmdtoken name $x]
} {{#} ::#}
test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}
test basic-22.1 {Tcl_GetCommandFullName} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_basic1 {
namespace export cmd*
proc cmd1 {} {}
proc cmd2 {} {}
}
namespace eval test_ns_basic2 {
namespace export *
namespace import ::test_ns_basic1::*
proc p {} {}
}
namespace eval test_ns_basic3 {
namespace import ::test_ns_basic2::*
proc q {} {}
list [namespace which -command foreach] \
[namespace which -command q] \
[namespace which -command p] \
[namespace which -command cmd1] \
[namespace which -command ::test_ns_basic2::cmd2]
}
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}
test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
} {}
test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
catch {interp delete test_interp}
unset -nocomplain x
interp create test_interp
interp eval test_interp {
proc useSet {} {
return [set a 123]
}
}
set x [interp eval test_interp {useSet}]
interp eval test_interp {
rename set ""
proc set {args} {
return "set called with $args"
}
}
list $x \
[interp eval test_interp {useSet}] \
[interp delete test_interp]
} {123 {set called with a 123} {}}
test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {
return "global p"
}
namespace eval test_ns_basic {
proc p {} {
return "namespace p"
}
proc callP {} {
p
}
}
list [test_ns_basic::callP] \
[rename test_ns_basic::p ""] \
[test_ns_basic::callP]
} {{namespace p} {} {global p}}
test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_basic {
namespace export p
proc p {} {return 42}
}
namespace eval test_ns_basic2 {
namespace import ::test_ns_basic::*
proc callP {} {
p
}
}
list [test_ns_basic2::callP] \
[info commands test_ns_basic2::*] \
[rename test_ns_basic::p ""] \
[catch {test_ns_basic2::callP} msg] $msg \
[info commands test_ns_basic2::*]
} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}
test basic-25.1 {TclCleanupCommand} {emptyTest} {
} {}
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup {
proc myHandler {msg options} {
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
} {}
test basic-36.1 {Tcl_EvalObjv, lookup of "unknown" command} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
| | | | | | | | | | | | 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 |
} {}
test basic-36.1 {Tcl_EvalObjv, lookup of "unknown" command} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
proc unknown {args} {
return "global unknown"
}
namespace eval test_ns_basic {
proc unknown {args} {
return "namespace unknown"
}
}
}
list [interp alias test_interp newAlias test_interp doesntExist] \
[catch {interp eval test_interp {newAlias}} msg] $msg \
[interp delete test_interp]
} {newAlias 0 {global unknown} {}}
test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
} {}
test basic-38.1 {Tcl_ExprObj} {emptyTest} {
} {}
|
| ︙ | ︙ | |||
756 757 758 759 760 761 762 |
3 {*}$::l1
# Comment again
}
} {1 2 3 a {b b} c d}
test basic-48.2.$noComp {no expansion} $constraints {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
3 {*}$::l1
# Comment again
}
} {1 2 3 a {b b} c d}
test basic-48.2.$noComp {no expansion} $constraints {
run {list $::l1 $::l2 [l3]}
} {{a {b b} c d} {e f {g g} h} {i j k {l l}}}
test basic-48.3.$noComp {expansion} $constraints {
run {list {*}$::l1 $::l2 {*}[l3]}
} {a {b b} c d {e f {g g} h} i j k {l l}}
test basic-48.4.$noComp {expansion: really long cmd} $constraints {
set cmd [list list]
for {set t 0} {$t < 500} {incr t} {
lappend cmd {{*}$::l1}
}
llength [run [join $cmd]]
} 2000
test basic-48.5.$noComp {expansion: error detection} -setup {
set l "a {a b}x y"
} -constraints $constraints -body {
run {list $::l1 {*}$l}
} -cleanup {
unset l
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
test basic-48.6.$noComp {expansion: odd usage} $constraints {
run {list {*}$::l1$::l2}
} {a {b b} c de f {g g} h}
test basic-48.7.$noComp {expansion: odd usage} -constraints $constraints -body {
run {list {*}[l3]$::l1}
} -returnCodes 1 -result {list element in braces followed by "a" instead of space}
test basic-48.8.$noComp {expansion: odd usage} $constraints {
run {list {*}hej$::l1}
} {heja {b b} c d}
test basic-48.9.$noComp {expansion: Not all {*} should trigger} $constraints {
run {list {*}$::l1 \{*\}$::l2 "{*}$::l1" {{*} i j k}}
} {a {b b} c d {{*}e f {g g} h} {{*}a {b b} c d} {{*} i j k}}
test basic-48.10.$noComp {expansion: expansion of command word} -setup {
set cmd [list string range jultomte]
} -constraints $constraints -body {
run {{*}$cmd 2 6}
} -cleanup {
unset cmd
} -result ltomt
test basic-48.11.$noComp {expansion: expansion into nothing} -setup {
set cmd {}
set bar {}
} -constraints $constraints -body {
run {{*}$cmd {*}$bar}
} -cleanup {
unset cmd bar
} -result {}
test basic-48.12.$noComp {expansion: odd usage} $constraints {
run {list {*}$::l1 {*}"hej hopp" {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}
test basic-48.13.$noComp {expansion: odd usage} $constraints {
run {list {*}$::l1 {*}{hej hopp} {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}
test basic-48.14.$noComp {expansion: hash command} -setup {
catch {rename \# ""}
set cmd "#"
} -constraints $constraints -body {
run { {*}$cmd apa bepa }
} -cleanup {
unset cmd
} -returnCodes 1 -result {invalid command name "#"}
test basic-48.15.$noComp {expansion: complex words} -setup {
set a(x) [list a {b c} d e]
set b x
set c [list {f\ g h\ i j k} x y]
set d {0\ 1 2 3}
} -constraints $constraints -body {
run { lappend d {*}$a($b) {*}[lindex $c 0] }
} -cleanup {
unset a b c d
} -result {{0 1} 2 3 a {b c} d e {f g} {h i} j k}
testConstraint memory [llength [info commands memory]]
test basic-48.16.$noComp {expansion: testing for leaks} -setup {
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
}
# This test is made to stress the allocation, reallocation and
# object reference management in Tcl_EvalEx.
proc stress {} {
set a x
# Create free objects that should disappear
set l [list 1$a 2$a 3$a 4$a 5$a 6$a 7$a]
# A short number of words and a short result (8)
set l [run {list {*}$l $a$a}]
# A short number of words and a longer result (27)
set l [run {list {*}$l $a$a {*}$l $a$a {*}$l $a$a}]
# A short number of words and a longer result, with an error
# This is to stress the cleanup in the error case
if {![catch {run {_moo_ {*}$l $a$a {*}$l $a$a {*}$l}}]} {
error "An error was expected in the previous statement"
}
# Many words
set l [run {list {*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a {*}$l $a$a \
{*}$l $a$a}]
if {[llength $l] != 19*28} {
error "Bad Length: [llength $l] should be [expr {19*28}]"
}
}
} -constraints [linsert $constraints 0 memory] -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
stress
set tmp $end
set end [getbytes]
}
set leak [expr {$end - $tmp}]
} -cleanup {
unset end i tmp
rename getbytes {}
rename stress {}
} -result 0
test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body {
set third [expr {1.0/3.0}]
set l [list $third $third]
set x [run {list $third {*}$l $third}]
set res [list]
foreach t $x {
lappend res [expr {$t * 3.0}]
}
set res
} -cleanup {
unset res t l x third
} -result {1.0 1.0 1.0 1.0}
test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body {
set badcmd {
list a b
set apa 10
}
set apa 0
list [llength [run { {*}$badcmd }]] $apa
} -cleanup {
unset apa badcmd
} -result {5 0}
test basic-48.19.$noComp {expansion: error checking order} -body {
set badlist "a {}x y"
set a 0
set b 0
catch {run {list [incr a] {*}$badlist [incr b]}}
list $a $b
} -constraints $constraints -cleanup {
unset badlist a b
} -result {1 0}
test basic-48.20.$noComp {expansion: odd case with word boundaries} $constraints {
run {list {*}$::l1 {*}"hej hopp" {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}
test basic-48.21.$noComp {expansion: odd case with word boundaries} $constraints {
run {list {*}$::l1 {*}{hej hopp} {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}
test basic-48.22.$noComp {expansion: odd case with word boundaries} -body {
run {list {*}$::l1 {*}"hej hopp {*}$::l2}
} -constraints $constraints -returnCodes error -result {missing "}
test basic-48.23.$noComp {expansion: handle return codes} -constraints $constraints -body {
set res {}
for {set t 0} {$t < 10} {incr t} {
run { {*}break }
}
lappend res $t
for {set t 0} {$t < 10} {incr t} {
run { {*}continue }
set t 20
}
lappend res $t
lappend res [catch { run { {*}{error Hejsan} } } err]
lappend res $err
} -cleanup {
unset res t
} -result {0 10 1 Hejsan}
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
|
| ︙ | ︙ |
Changes to tests/bigdata.test.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
# only be used when operands are not modified and when combining tests
# does not consume too much additional memory.
# Wrapper to generate compiled and uncompiled cases for a test. If $args does
# not contain a -body key, $comment is treated as the test body
proc bigtest {id comment result args} {
if {[dict exists $args -body]} {
| | | | | | | | | | | | | | | | | | | | | 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 |
# only be used when operands are not modified and when combining tests
# does not consume too much additional memory.
# Wrapper to generate compiled and uncompiled cases for a test. If $args does
# not contain a -body key, $comment is treated as the test body
proc bigtest {id comment result args} {
if {[dict exists $args -body]} {
set body [dict get $args -body]
dict unset args -body
} else {
set body $comment
}
dict lappend args -constraints bigdata
uplevel 1 [list test $id.uncompiled "$comment (uncompiled)" \
-body [list testevalex $body] \
-result $result \
{*}$args]
uplevel 1 [list test $id.compiled-script "$comment (compiled script)" \
-body [list try $body] \
-result $result \
{*}$args]
return
# TODO - is this proc compilation required separately from the compile-script above?
dict append args -setup \n[list proc testxproc {} $body]
dict append args -cleanup "\nrename testxproc {}"
uplevel 1 [list test $id.compiled-proc "$comment (compiled proc)" \
-body {testxproc} \
-result $result \
{*}$args]
}
# Like bigtest except that both compiled and uncompiled are combined into one
# test using the same inout argument. This saves time but for obvious reasons
# should only be used when the input argument is not modified.
proc bigtestRO {id comment result args} {
if {[dict exists $args -body]} {
set body [dict get $args -body]
dict unset args -body
} else {
set body $comment
}
dict lappend args -constraints bigdata
set wrapper ""
set body "{$body}"
append wrapper "set uncompiled_result \[testevalex $body]" \n
append wrapper "set compiled_result \[try $body]" \n
append wrapper {list $uncompiled_result $compiled_result}
uplevel 1 [list test $id.uncompiled,compiled {$comment} \
-body $wrapper \
-result [list $result $result] \
{*}$args]
return
}
interp alias {} bigClean {} unset -nocomplain s s1 s2 bin bin1 bin2 l l1 l2
interp alias {} bigString {} testbigdata string
interp alias {} bigBinary {} testbigdata bytearray
interp alias {} bigList {} testbigdata list
proc bigPatLen {} {
proc bigPatLen {} "return [string length [testbigdata string]]"
bigPatLen
}
# Returns list of expected elements at the indices specified
proc bigStringIndices {indices} {
set pat [testbigdata string]
set patlen [string length $pat]
lmap idx $indices {
string index $pat [expr {$idx%$patlen}]
}
}
# Returns the largest multiple of the pattern length that is less than $limit
proc bigPatlenMultiple {limit} {
set patlen [bigPatLen]
return [expr {($limit/$patlen)*$patlen}]
|
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
bigClean
} -constraints panic-in-EnterCmdStartData
#
# string cat
bigtest string-cat-bigdata-1 "string cat large small result > INT_MAX" 1 -body {
string equal \
| | | | | | | | 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 |
bigClean
} -constraints panic-in-EnterCmdStartData
#
# string cat
bigtest string-cat-bigdata-1 "string cat large small result > INT_MAX" 1 -body {
string equal \
[string cat [bigString $::bigLengths(patlenmultiple)] [bigString]] \
[bigString [expr {[bigPatLen]+$::bigLengths(patlenmultiple)}]]
}
bigtest string-cat-bigdata-2 "string cat small large result > INT_MAX" 1 -body {
string equal \
[string cat [bigString] [bigString $::bigLengths(patlenmultiple)]] \
[bigString [expr {[bigPatLen]+$::bigLengths(patlenmultiple)}]]
}
bigtest string-cat-bigdata-3 "string cat result > UINT_MAX" 1 -body {
set s [bigString $::bigLengths(patlenmultiple)]
string equal \
[string cat $s [bigString] $s] \
[bigString [expr {[bigPatLen]+2*$::bigLengths(patlenmultiple)}]]
}
#
# string compare/equal
bigtestRO string-equal/compare-bigdata-1 "string compare/equal equal strings" {0 1} -body {
list [string compare $s1 $s2] [string equal $s1 $s2]
} -setup {
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
bigClean
}
#
# string first
bigtestRO string-first-bigdata-1 "string first > INT_MAX" {2147483648 -1 2147483650 1} -body {
list \
| | | | | | | | | | | | | | | | | | | 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 |
bigClean
}
#
# string first
bigtestRO string-first-bigdata-1 "string first > INT_MAX" {2147483648 -1 2147483650 1} -body {
list \
[string first X $s] \
[string first Y $s] \
[string first 0 $s 0x80000000] \
[string first 1 $s end-0x80000010]
} -setup {
set s [bigString 0x8000000a 0x80000000]
} -cleanup {
bigClean
}
bigtestRO string-first-bigdata-2 "string first > UINT_MAX" {4294967296 -1 4294967300 1} -body {
list \
[string first X $s] \
[string first Y $s] \
[string first 0 $s 0x100000000] \
[string first 1 $s end-0x100000010]
} -setup {
set s [bigString 0x10000000a 0x100000000]
} -cleanup {
bigClean
}
bigtestRO string-first-bigdata-3 "string first - long needle" 10 -body {
string first $needle $s
} -setup {
set s [bigString 0x10000000a 0]
set needle [bigString 0x100000000]
} -cleanup {
bigClean needle
}
#
# string index
bigtestRO string-index-bigdata-1 "string index" {6 7 5 {} 5 4 {} 9 {}} -body {
list \
[string index $s 0x100000000] \
[string index $s 0x100000000+1] \
[string index $s 0x100000000-1] \
[string index $s 0x10000000a] \
[string index $s end] \
[string index $s end-1] \
[string index $s end+1] \
[string index $s end-0x100000000] \
[string index $s end-0x10000000a]
} -setup {
set s [bigString 0x10000000a]
} -cleanup {
bigClean
}
#
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
}
#
# string last
bigtestRO string-last-bigdata-1 "string last > INT_MAX" {2 -1 2147483640 11} -body {
set s [bigString 0x80000010 2]
list \
| | | | | | | | | | 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 |
}
#
# string last
bigtestRO string-last-bigdata-1 "string last > INT_MAX" {2 -1 2147483640 11} -body {
set s [bigString 0x80000010 2]
list \
[string last X $s] \
[string last Y $s] \
[string last 0 $s 0x80000000] \
[string last 1 $s end-0x80000000]
} -setup {
set s [bigString 0x80000010 2]
} -cleanup {
bigClean
}
bigtestRO string-last-bigdata-2 "string last > UINT_MAX" {4294967320 -1 4294967290 1} -body {
list \
[string last 0 $s] \
[string last Y $s] \
[string last 0 $s 0x100000000] \
[string last 1 $s end-0x100000010]
} -setup {
set s [bigString 0x10000001a 2]
} -cleanup {
bigClean
}
bigtestRO string-last-bigdata-3 "string last - long needle" 0 -body {
string last $needle $s
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
# string map
bigtestRO string-map-bigdata-1 {string map} {5 0 0 5} -body {
# Unset explicitly before setting to save memory as bigtestRO runs the
# script below twice.
unset -nocomplain s2
set s2 [string map {0 5 5 0} $s]
list \
| | | | | | | | | | | | | | | | | | 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 |
# string map
bigtestRO string-map-bigdata-1 {string map} {5 0 0 5} -body {
# Unset explicitly before setting to save memory as bigtestRO runs the
# script below twice.
unset -nocomplain s2
set s2 [string map {0 5 5 0} $s]
list \
[string index $s2 0] \
[string index $s2 5] \
[string index $s2 end] \
[string index $s2 end-5]
} -setup {
set s [bigString 0x100000000]
} -cleanup {
bigClean
} -constraints bug-takesTooLong
#
# string match
bigtestRO string-match-bigdata-1 {string match} {1 0 1} -body {
list \
[string match 0*5 $s] \
[string match 0*4 $s] \
[string match $s $s]
} -setup {
set s [bigString 0x100000000]
} -cleanup {
bigClean
}
#
# string range
bigtestRO string-range-bigdata-1 "string range" {6 7 5 {} 5 4 {} 9 {}} -body {
list \
[string range $s 0x100000000 0x100000000] \
[string range $s 0x100000000+1 0x100000000+1] \
[string range $s 0x100000000-1 0x100000000-1] \
[string range $s 0x10000000a 0x10000000a] \
[string range $s end end] \
[string range $s end-1 end-1] \
[string range $s end+1 end+1] \
[string range $s end-0x100000000 end-0x100000000] \
[string range $s end-0x10000000a end-0x10000000a]
} -setup {
set s [bigString 0x10000000a]
} -cleanup {
bigClean
}
bigtestRO string-range-bigdata-2 "bug ad9361fd20 case 1" aXaaaa -body {
string range [string insert [string repeat a 0x80000000] end-0x7fffffff X] 0 5
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
# string repeat - use bigtest, not bigtestRO !!
bigtest string-repeat-bigdata-1 "string repeat single char length > UINT_MAX" 4294967296 -body {
string length [string repeat x 0x100000000]
}
bigtest string-repeat-bigdata-2 "string repeat multiple char" {4294967296 0123456789abcdef 0123456789abcdef} -body {
set s [string repeat 0123456789abcdef [expr 0x100000000/16]]
list \
| | | | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
# string repeat - use bigtest, not bigtestRO !!
bigtest string-repeat-bigdata-1 "string repeat single char length > UINT_MAX" 4294967296 -body {
string length [string repeat x 0x100000000]
}
bigtest string-repeat-bigdata-2 "string repeat multiple char" {4294967296 0123456789abcdef 0123456789abcdef} -body {
set s [string repeat 0123456789abcdef [expr 0x100000000/16]]
list \
[string length $s] \
[string range $s 0 15] \
[string range $s end-15 end]
} -cleanup {
bigClean
}
#
# string replace
bigtestRO string-replace-bigdata-1 "string replace" {789012345 012345678 XYZ789012345 012345678XYZ} -body {
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
#
# foreach
bigtestRO foreach-bigdata-1 "foreach" 1 -body {
# Unset explicitly before setting as bigtestRO runs the script twice.
unset -nocomplain l2
foreach x $l {
| | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
#
# foreach
bigtestRO foreach-bigdata-1 "foreach" 1 -body {
# Unset explicitly before setting as bigtestRO runs the script twice.
unset -nocomplain l2
foreach x $l {
lappend l2 $x
}
testlutil equal $l $l2
} -setup {
set l [bigList 0x100000000]
} -cleanup {
bigClean
}
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
bigClean
} -constraints memory-allocation-panic
#
# lindex
bigtestRO lindex-bigdata-1 "lindex" {6 7 5 {} 5 4 {} 9 {}} -body {
list \
| | | | | | | | | | | | | 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 |
bigClean
} -constraints memory-allocation-panic
#
# lindex
bigtestRO lindex-bigdata-1 "lindex" {6 7 5 {} 5 4 {} 9 {}} -body {
list \
[lindex $l 0x100000000] \
[lindex $l 0x100000000+1] \
[lindex $l 0x100000000-1] \
[lindex $l 0x10000000a] \
[lindex $l end] \
[lindex $l end-1] \
[lindex $l end+1] \
[lindex $l end-0x100000000] \
[lindex $l end-0x10000000a]
} -setup {
set l [bigList 0x10000000a]
} -cleanup {
bigClean
}
# TODO nested index
#
# linsert
# Cannot use bigtestRO here because 16GB memory not enough to have two 4G sized lists
# Have to throw away source list every time. Also means we cannot compare entire lists
# and instead just compare the affected range
bigtest linsert-bigdata-1 "linsert" {4294967330 1} -body {
# Note insert at multiple of 10 to enable comparison against generated string
set ins [split abcdefghij ""]
set pat [split 0123456789 ""]
set insidx 2000000000
set l [linsert [bigList 4294967320] $insidx {*}$ins]
list \
[llength $l] \
[testlutil equal [lrange $l $insidx-10 $insidx+19] [concat $pat $ins $pat]]
} -cleanup {
bigClean
}
#
# list and {*}
# TODO - compiled and uncompiled behave differently so tested separately
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
}
#
# lmap
bigtestRO lmap-bigdata-1 "lmap" 4294967296 -body {
set n 0
if {0} {
| | | | | | | | | | | | | | | | 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 |
}
#
# lmap
bigtestRO lmap-bigdata-1 "lmap" 4294967296 -body {
set n 0
if {0} {
# TODO - This is the right test but runs out of memory
testlutil equal $l [lmap e $l {set e}]
} else {
lmap e $l {incr n; continue}
}
set n
} -setup {
set l [bigList 0x100000000]
} -cleanup {
bigClean
puts ""
}
#
# lrange
bigtestRO lrange-bigdata-1 "lrange" {6 {6 7} 7 5 {} 5 4 {} 9 {8 9} {}} -body {
list \
[lrange $l 0x100000000 0x100000000] \
[lrange $l 0x100000000 0x100000001] \
[lrange $l 0x100000000+1 0x100000000+1] \
[lrange $l 0x100000000-1 0x100000000-1] \
[lrange $l 0x10000000a 0x10000000a] \
[lrange $l end end] \
[lrange $l end-1 end-1] \
[lrange $l end+1 end+1] \
[lrange $l end-0x100000000 end-0x100000000] \
[lrange $l end-0x100000001 end-0x100000000] \
[lrange $l end-0x10000000a end-0x10000000a]
} -setup {
set l [bigList 0x10000000a]
} -cleanup {
bigClean
}
# TODO - add tests for large result range
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 |
} -cleanup {
bigClean
}
#
# lreplace
bigtestRO lreplace-bigdata-1 "lreplace - small result" [list \
| | | | | | | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 |
} -cleanup {
bigClean
}
#
# lreplace
bigtestRO lreplace-bigdata-1 "lreplace - small result" [list \
[split 789012345 ""] \
[split 012345678 ""] \
[split XYZ789012345 ""] \
[split 012345678XYZ ""] \
] -body {
# Unset explicitly before setting to save memory as bigtestRO runs the
# script below twice.
unset -nocomplain result
lappend result [lreplace $l 0 0x100000000]
lappend result [lreplace $l end-0x100000000 end]
lappend result [lreplace $l 0 0x100000000 X Y Z]
lappend result [lreplace $l end-0x100000000 end X Y Z]
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 |
bigClean
} -constraints bug-outofmemorypanic
#
# lsearch
bigtestRO lsearch-bigdata-1 "lsearch" {4294967300 4294967310 -1} -body {
list \
| | | | | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 |
bigClean
} -constraints bug-outofmemorypanic
#
# lsearch
bigtestRO lsearch-bigdata-1 "lsearch" {4294967300 4294967310 -1} -body {
list \
[lsearch -exact $l X] \
[lsearch -exact -start 4294967291 $l 0] \
[lsearch -exact $l Y]
} -setup {
set l [bigList 0x100000010 4294967300]
} -cleanup {
bigClean
}
# TODO - stride, inline, all
|
| ︙ | ︙ |
Changes to tests/binary.test.
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
} PR
test binary-8.9 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format c2 {0x50}
} -result {number of elements in list does not match count}
test binary-8.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format c $a
| | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
} PR
test binary-8.9 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format c2 {0x50}
} -result {number of elements in list does not match count}
test binary-8.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format c $a
} -result "expected integer but got a list"
test binary-8.11 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format c1 $a
} P
test binary-9.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format s
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 |
} P\x00R\x00
test binary-9.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format s2 {0x50}
} -result {number of elements in list does not match count}
test binary-9.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format s $a
| | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
} P\x00R\x00
test binary-9.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format s2 {0x50}
} -result {number of elements in list does not match count}
test binary-9.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format s $a
} -result "expected integer but got a list"
test binary-9.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format s1 $a
} P\x00
test binary-10.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format S
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
} \x00P\x00R
test binary-10.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format S2 {0x50}
} -result {number of elements in list does not match count}
test binary-10.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format S $a
| | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
} \x00P\x00R
test binary-10.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format S2 {0x50}
} -result {number of elements in list does not match count}
test binary-10.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format S $a
} -result "expected integer but got a list"
test binary-10.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format S1 $a
} \x00P
test binary-11.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
} SRQPR\x00\x00\x00
test binary-11.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i2 {0x50}
} -result {number of elements in list does not match count}
test binary-11.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format i $a
| | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 |
} SRQPR\x00\x00\x00
test binary-11.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i2 {0x50}
} -result {number of elements in list does not match count}
test binary-11.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format i $a
} -result "expected integer but got a list"
test binary-11.13 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format i1 $a
} P\x00\x00\x00
test binary-12.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format I
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
} PQRS\x00\x00\x00R
test binary-12.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i2 {0x50}
} -result {number of elements in list does not match count}
test binary-12.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format I $a
| | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
} PQRS\x00\x00\x00R
test binary-12.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i2 {0x50}
} -result {number of elements in list does not match count}
test binary-12.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format I $a
} -result "expected integer but got a list"
test binary-12.13 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format I1 $a
} \x00\x00\x00P
test binary-13.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format f
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
} \x00\x00\x00\x80
test binary-13.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format f2 {1.6}
} -result {number of elements in list does not match count}
test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format f $a
| | | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
} \x00\x00\x00\x80
test binary-13.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format f2 {1.6}
} -result {number of elements in list does not match count}
test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format f $a
} -result "expected floating-point number but got a list"
test binary-13.18 {Tcl_BinaryObjCmd: format} bigEndian {
set a {1.6 3.4}
binary format f1 $a
} \x3F\xCC\xCC\xCD
test binary-13.19 {Tcl_BinaryObjCmd: format} littleEndian {
set a {1.6 3.4}
binary format f1 $a
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format d2 {1.6}
} -result {number of elements in list does not match count}
test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format d $a
| | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format d2 {1.6}
} -result {number of elements in list does not match count}
test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format d $a
} -result "expected floating-point number but got a list"
test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian {
set a {1.6 3.4}
binary format d1 $a
} \x3F\xF9\x99\x99\x99\x99\x99\x9A
test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian {
set a {1.6 3.4}
binary format d1 $a
|
| ︙ | ︙ | |||
1810 1811 1812 1813 1814 1815 1816 |
} P\x00R\x00
test binary-48.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format t2 {0x50}
} -result {number of elements in list does not match count}
test binary-48.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format t $a
| | | 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 |
} P\x00R\x00
test binary-48.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format t2 {0x50}
} -result {number of elements in list does not match count}
test binary-48.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format t $a
} -result "expected integer but got a list"
test binary-48.18 {Tcl_BinaryObjCmd: format} bigEndian {
set a {0x50 0x51}
binary format t1 $a
} \x00P
test binary-48.19 {Tcl_BinaryObjCmd: format} littleEndian {
set a {0x50 0x51}
binary format t1 $a
|
| ︙ | ︙ | |||
1857 1858 1859 1860 1861 1862 1863 |
} SRQPR\x00\x00\x00
test binary-49.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format n2 {0x50}
} -result {number of elements in list does not match count}
test binary-49.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format n $a
| | | 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 |
} SRQPR\x00\x00\x00
test binary-49.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format n2 {0x50}
} -result {number of elements in list does not match count}
test binary-49.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format n $a
} -result "expected integer but got a list"
test binary-49.13 {Tcl_BinaryObjCmd: format} littleEndian {
set a {0x50 0x51}
binary format n1 $a
} P\x00\x00\x00
test binary-49.14 {Tcl_BinaryObjCmd: format} bigEndian {
binary format n 0x50
} \x00\x00\x00P
|
| ︙ | ︙ | |||
1940 1941 1942 1943 1944 1945 1946 |
} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format q2 {1.6}
} -result {number of elements in list does not match count}
test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format q $a
| | | 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format q2 {1.6}
} -result {number of elements in list does not match count}
test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format q $a
} -result "expected floating-point number but got a list"
test binary-51.16 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format Q1 $a
} \x3F\xF9\x99\x99\x99\x99\x99\x9A
test binary-51.17 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format q1 $a
|
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 |
} \x00\x00\x00\x80
test binary-53.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format r2 {1.6}
} -result {number of elements in list does not match count}
test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format r $a
| | | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 |
} \x00\x00\x00\x80
test binary-53.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format r2 {1.6}
} -result {number of elements in list does not match count}
test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format r $a
} -result "expected floating-point number but got a list"
test binary-53.18 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format R1 $a
} \x3F\xCC\xCC\xCD
test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format r1 $a
|
| ︙ | ︙ | |||
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 3059 3060 3061 3062 3063 3064 3065 |
} -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 {
bigmem testbytestring pointerIs64bit deprecated
} -body {
testbytestring [string repeat A [expr 2**31]]
} -returnCodes 1 -result "byte sequence length exceeds INT_MAX"
# ----------------------------------------------------------------------
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/chan.test.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 |
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?arg ...?\""
test chan-1.2 {chan command general syntax} -body {
chan FOOBAR
} -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *"
test chan-2.1 {chan command: blocked subcommand} -body {
chan blocked foo bar
| | | | | | | | | | | | | | > > > > > > > > > > | | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 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 |
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?arg ...?\""
test chan-1.2 {chan command general syntax} -body {
chan FOOBAR
} -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *"
test chan-2.1 {chan command: blocked subcommand} -body {
chan blocked foo bar
} -returnCodes error -result "wrong # args: should be \"chan blocked channel\""
test chan-3.1 {chan command: close subcommand} -body {
chan close foo bar zet
} -returnCodes error -result "wrong # args: should be \"chan close channel ?direction?\""
test chan-3.2 {chan command: close subcommand} -setup {
set chan [open [info script] r]
} -body {
chan close $chan bar
} -cleanup {
close $chan
} -returnCodes error -result "bad direction \"bar\": must be read or write"
test chan-3.3 {chan command: close subcommand} -setup {
set chan [open [info script] r]
} -body {
chan close $chan write
} -cleanup {
close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
test chan-4.1 {chan command: configure subcommand} -body {
chan configure
} -returnCodes error -result "wrong # args: should be \"chan configure channel ?-option value ...?\""
test chan-4.2 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar Ā
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.3 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar \x00
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body {
chan configure stdout -eofchar [list \x27 {}]
} -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""
test chan-6.1 {chan command: eof subcommand} -body {
chan eof foo bar
} -returnCodes error -result "wrong # args: should be \"chan eof channel\""
test chan-7.1 {chan command: event subcommand} -body {
chan event foo
} -returnCodes error -result "wrong # args: should be \"chan event channel event ?script?\""
test chan-8.1 {chan command: flush subcommand} -body {
chan flush foo bar
} -returnCodes error -result "wrong # args: should be \"chan flush channel\""
test chan-9.1 {chan command: gets subcommand} -body {
chan gets
} -returnCodes error -result "wrong # args: should be \"chan gets channel ?varName?\""
test chan-10.1 {chan command: names subcommand} -body {
chan names foo bar
} -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\""
test chan-11.1 {chan command: puts subcommand} -body {
chan puts foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channel? string\""
test chan-12.1 {chan command: read subcommand} -body {
chan read
} -returnCodes error -result "wrong # args: should be \"chan read channel ?numChars?\" or \"chan read ?-nonewline? channel\""
test chan-13.1 {chan command: seek subcommand} -body {
chan seek foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan seek channel offset ?origin?\""
test chan-14.1 {chan command: tell subcommand} -body {
chan tell foo bar
} -returnCodes error -result "wrong # args: should be \"chan tell channel\""
test chan-15.1 {chan command: truncate subcommand} -body {
chan truncate foo bar foo bar
} -returnCodes error -result "wrong \# args: should be \"chan truncate channel ?length?\""
test chan-15.2 {chan command: truncate subcommand} -setup {
set file [makeFile {} testTruncate]
set f [open $file w+]
fconfigure $f -translation binary
} -body {
seek $f 0
puts -nonewline $f 12345
seek $f 0
chan truncate $f 2
read $f
} -result 12 -cleanup {
catch {close $f}
catch {removeFile $file}
}
test chan-15.3 {chan command: isbinary subcommand} -setup {
set file [makeFile {} testIsBinary]
set f [open $file w+]
fconfigure $f -translation binary
} -body {
chan isbinary $f
} -result 1 -cleanup {
catch {close $f}
catch {removeFile $file}
}
# TIP 287: chan pending
test chan-16.1 {chan command: pending subcommand} -body {
chan pending
} -returnCodes error -result "wrong # args: should be \"chan pending mode channel\""
test chan-16.2 {chan command: pending subcommand} -body {
chan pending stdin
} -returnCodes error -result "wrong # args: should be \"chan pending mode channel\""
test chan-16.3 {chan command: pending subcommand} -body {
chan pending stdin stdout stderr
} -returnCodes error -result "wrong # args: should be \"chan pending mode channel\""
test chan-16.4 {chan command: pending subcommand} -body {
chan pending {input output} stdout
} -returnCodes error -result "bad mode \"input output\": must be input or output"
test chan-16.5 {chan command: pending input subcommand} -body {
chan pending input stdout
} -result -1
test chan-16.6 {chan command: pending input subcommand} -body {
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
chan pending input $f
} -result 8 -cleanup {
catch {chan close $f}
catch {removeFile $file}
}
test chan-16.9 {chan command: pending input subcommand} -setup {
proc chan-16.9-accept {sock addr port} {
| | | | | | | | | | | | | | | | | | | 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 |
chan pending input $f
} -result 8 -cleanup {
catch {chan close $f}
catch {removeFile $file}
}
test chan-16.9 {chan command: pending input subcommand} -setup {
proc chan-16.9-accept {sock addr port} {
chan configure $sock -blocking 0 -buffering line -buffersize 32
chan event $sock readable [list chan-16.9-readable $sock]
}
proc chan-16.9-readable {sock} {
set r [chan gets $sock line]
set l [string length $line]
set e [chan eof $sock]
set b [chan blocked $sock]
set i [chan pending input $sock]
lappend ::chan-16.9-data $r $l $e $b $i
if {$r >= 0 || $e || $l || !$b || $i > 128} {
set data [read $sock $i]
lappend ::chan-16.9-data [string range $data 0 2]
lappend ::chan-16.9-data [string range $data end-2 end]
set ::chan-16.9-done 1
chan event $sock readable {}
} else {
after idle chan-16.9-client
}
}
proc chan-16.9-client {} {
chan puts -nonewline $::client ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890
chan flush $::client
}
set ::server [socket -server chan-16.9-accept -myaddr 127.0.0.1 0]
set ::client [socket 127.0.0.1 [lindex [fconfigure $::server -sockname] 2]]
set ::chan-16.9-data [list]
set ::chan-16.9-done 0
} -body {
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 |
testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}]
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
| | | | | 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 |
testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}]
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
chan configure $f -translation lf
for { set i 0 } { $i < 100 } { incr i} {
chan puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
\#"
}
chan close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
chan configure $f -translation binary -blocking 0 -eofchar \x1A
chan configure stdout -translation binary -buffering none
chan event $f readable "foo $f"
proc foo {f} {
set x [chan read $f]
catch {chan puts -nonewline $x}
if {[chan eof $f]} {
chan close $f
exit 0
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test chan-io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test chan-io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f "a\x4D\x00"
chan close $f
contents $path(test1)
} aM\x00
test chan-io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
chan configure $f -encoding shiftjis
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
chan close $f
lappend sizes [file size $path(test2)]
} {19 19 19 19 19}
test chan-io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
| | | | | < | 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 |
chan close $f
lappend sizes [file size $path(test2)]
} {19 19 19 19 19}
test chan-io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
chan configure $f -translation binary -buffersize 16 -translation crlf
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test chan-io-2.2 {WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
chan configure $f -translation binary -buffersize 16 -translation crlf
chan puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
chan close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test chan-io-2.3 {WriteBytes: flush on line} -body {
# Tcl "line" buffering has weird behavior: if current buffer contains a
# \n, entire buffer gets flushed. Logical behavior would be to flush only
# up to the \n.
set f [open $path(test1) w]
chan configure $f -translation binary -buffering line -translation crlf
chan puts -nonewline $f "\n12"
contents $path(test1)
} -cleanup {
chan close $f
} -result "\r\n12"
test chan-io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
chan configure $f -translation binary -buffering line -buffersize 16
chan puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
chan close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test chan-io-3.1 {WriteChars: compatibility with WriteBytes} {
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 |
chan puts -nonewline $f "12345678901\n456789012345678901234"
chan close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test chan-io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
| < | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
chan puts -nonewline $f "12345678901\n456789012345678901234"
chan close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test chan-io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
chan puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
chan close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test chan-io-5.2 {CheckFlush: full} {
set f [open $path(test1) w]
|
| ︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 |
chan gets $f
} -cleanup {
chan close $f
} -result "123456789012301234"
test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
| | | | | | 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 |
chan gets $f
} -cleanup {
chan close $f
} -result "123456789012301234"
test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis
list [chan gets $f line] $line [chan eof $f]
} -cleanup {
chan close $f
} -result {10 1234567890 0}
test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
set x ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis -profile tcl8
lappend x [chan gets $f line] $line
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 16 "123456789012301\x82" 18 0 1 -1 ""]
test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
variable x ""
} -constraints {stdio fileevent} -body {
set f [openpipe w+ $path(cat)]
chan configure $f -translation binary -buffering none
chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
chan configure $f -encoding shiftjis -blocking 0
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [chan blocked $f]
}]
vwait [namespace which -variable x]
chan configure $f -translation binary -blocking 1
chan puts $f "\x51\x82\x52"
chan configure $f -encoding shiftjis
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list -1 "" 1 17 "12345678901230123" 0]
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
chan configure $f -translation binary
chan puts $f "${a}\r\nabcdef"
chan close $f
set f [open $path(test1)]
| | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
chan configure $f -translation binary
chan puts $f "${a}\r\nabcdef"
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary -translation auto
# "${a}\r" was converted in one operation (because ENCODING_LINESIZE is
# 30). To check if "\n" follows, calls PeekAhead and determines that
# cached data is available in buffer w/o having to call driver.
chan gets $f
} -cleanup {
chan close $f
} -result $a
|
| ︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 |
test chan-io-11.1 {ReadBytes: want to read a lot} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
| | | | | | 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 |
test chan-io-11.1 {ReadBytes: want to read a lot} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary
# here
chan read $f 1000
} -cleanup {
chan close $f
} -result {abcdefghijkl}
test chan-io-11.2 {ReadBytes: want to read all} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary
# here
chan read $f
} -cleanup {
chan close $f
} -result {abcdefghijkl}
test chan-io-11.3 {ReadBytes: allocate more space} -body {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz
chan close $f
set f [open $path(test1)]
chan configure $f -buffersize 16 -translation binary
# here
chan read $f
} -cleanup {
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-11.4 {ReadBytes: EOF char found} -body {
# (TranslateInputEOL() != 0)
set f [open $path(test1) w]
chan puts $f abcdefghijklmnopqrstuvwxyz
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary -eofchar m
# here
list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f]
} -cleanup {
chan close $f
} -result {abcdefghijkl 1 {} 1}
test chan-io-12.1 {ReadChars: want to read a lot} -body {
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-12.4 {ReadChars: split-up char} -setup {
variable x {}
} -constraints {stdio testchannel fileevent} -body {
# (srcRead == 0)
set f [openpipe w+ $path(cat)]
| | | | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 |
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-12.4 {ReadChars: split-up char} -setup {
variable x {}
} -constraints {stdio testchannel fileevent} -body {
# (srcRead == 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation binary -buffering none -buffersize 16
chan puts -nonewline $f "123456789012345\x96"
chan configure $f -encoding shiftjis -blocking 0
chan event $f read [namespace code {
lappend x [chan read $f] [testchannel inputbuffered $f]
}]
chan configure $f -encoding shiftjis
vwait [namespace which -variable x]
chan configure $f -translation binary -blocking 1
chan puts -nonewline $f \x7B
after 500 ;# Give the cat process time to catch up
chan configure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list "123456789012345" 1 本 0]
test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
variable x {}
} -constraints {stdio fileevent} -body {
set path(test1) [makeFile {
chan configure stdout -translation binary -buffering none
chan gets stdin; chan puts -nonewline \xE7
chan gets stdin; chan puts -nonewline \x89
chan gets stdin; chan puts -nonewline \xA6
} test1]
set f [openpipe r+ $path(test1)]
chan event $f readable [namespace code {
lappend x [chan read $f]
|
| ︙ | ︙ | |||
1715 1716 1717 1718 1719 1720 1721 |
} -result hello
test chan-io-14.9 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
} -constraints {stdio fileevent} -body {
set f [open $path(script) w]
chan puts $f {
| | | 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 |
} -result hello
test chan-io-14.9 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
} -constraints {stdio fileevent} -body {
set f [open $path(script) w]
chan puts $f {
array set path [lindex $argv 0]
set f [open $path(test1) w]
chan puts $f hello
chan close $f
chan close stderr
set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
chan puts [chan gets $f]
}
|
| ︙ | ︙ | |||
1949 1950 1951 1952 1953 1954 1955 |
chan close $f
} -result "file"
test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup {
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
| | | 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 |
chan close $f
} -result "file"
test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup {
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f "1234567890\n098765432"
chan close $f
set f [open $path(test1) r]
chan gets $f
lappend l [testchannel inputbuffered $f]
lappend l [chan tell $f]
} -cleanup {
|
| ︙ | ︙ | |||
2001 2002 2003 2004 2005 2006 2007 |
chan close $f
} -result 0
test chan-io-27.2 {FlushChannel, some output buffered} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | | | | | 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 |
chan close $f
} -result 0
test chan-io-27.2 {FlushChannel, some output buffered} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello
lappend l [file size $path(test1)]
chan flush $f
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
} -result {0 6 6}
test chan-io-27.3 {FlushChannel, implicit flush on chan close} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
} -result {0 6}
test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan configure $f -buffersize 60
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
}
lappend l [file size $path(test1)]
chan flush $f
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 60 72}
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
set l ""
} -constraints {unixOrWin} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffersize 60
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
}
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
} -result {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close} -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {
chan configure $f -translation lf -buffering none
while {![chan eof stdin]} {
after 20
chan puts -nonewline $f [chan read stdin 1024]
}
chan close $f
}
chan close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
chan close $f
set f [openpipe w $path(pipe)]
chan configure $f -blocking off
chan puts -nonewline $f $x
chan close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
after 20 [list incr [namespace which -variable counter]]
vwait [namespace which -variable counter]
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} -result ok
# Tests closing a channel. The functions tested are Chan CloseChannel and
# Tcl_Chan Close.
test chan-io-28.1 {Chan CloseChannel called when all references are dropped} -setup {
|
| ︙ | ︙ | |||
2129 2130 2131 2132 2133 2134 2135 |
} -result abcdef
test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close nonPortable} -body {
set f [open $path(pipe) w]
chan puts $f {
| < < < < < | | | | | 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 |
} -result abcdef
test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close nonPortable} -body {
set f [open $path(pipe) w]
chan puts $f {
set f [open $path(output) w]
chan configure $f -translation lf -buffering none
for {set x 0} {$x < 20} {incr x} {
after 20
chan puts -nonewline $f [chan read stdin 1024]
}
chan close $f
}
chan close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
chan close $f
set f [openpipe r+ $path(pipe)]
chan configure $f -blocking off
chan puts -nonewline $f $x
chan close $f
set counter 0
while {([file size $path(output)] < 20480) && ($counter < 1000)} {
after 20 [list incr [namespace which -variable counter]]
vwait [namespace which -variable counter]
}
if {$counter == 1000} {
set result probably_broken
} else {
set result ok
}
} -result ok
test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup {
file delete $path(test1)
set l ""
} -body {
lappend l [lsort [testchannel open]]
|
| ︙ | ︙ | |||
2267 2268 2269 2270 2271 2272 2273 |
test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body {
chan puts stdin hello
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.2 {Tcl_WriteChars, empty string} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| < < | | | | | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 |
test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body {
chan puts stdin hello
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.2 {Tcl_WriteChars, empty string} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan puts -nonewline $f ""
chan close $f
file size $path(test1)
} -result 0
test chan-io-29.3 {Tcl_WriteChars, nonempty string} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan puts -nonewline $f hello
chan close $f
file size $path(test1)
} -result 5
test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering full
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {6 0 0 6}
test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering line
chan puts -nonewline $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {5 0 0 11}
test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering none
chan puts -nonewline $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 5 0 11}
test chan-io-29.7 {Tcl_Flush, full buffering} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering full
chan puts -nonewline $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan flush $f
|
| ︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 |
test chan-io-29.9 {Tcl_Flush, channel not writable} -body {
chan flush stdin
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | < | 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 |
test chan-io-29.9 {Tcl_Flush, channel not writable} -body {
chan flush stdin
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
chan puts $f1 [chan gets $f2]
}
chan close $f2
chan close $f1
file size $path(test1)
} -result 387
test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
chan puts -nonewline $f1 [chan gets $f2]
}
chan close $f1
chan close $f2
file size $path(test1)
|
| ︙ | ︙ | |||
2519 2520 2521 2522 2523 2524 2525 |
} -cleanup {
chan close $f1
} -result {18 24 30}
test chan-io-29.19 {Explicit and implicit flushes} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | 2509 2510 2511 2512 2513 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 |
} -cleanup {
chan close $f1
} -result {18 24 30}
test chan-io-29.19 {Explicit and implicit flushes} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
set x ""
chan puts $f1 hello
chan puts $f1 hello
chan puts $f1 hello
chan flush $f1
lappend x [file size $path(test1)]
chan puts $f1 hello
chan flush $f1
lappend x [file size $path(test1)]
chan puts $f1 hello
chan close $f1
lappend x [file size $path(test1)]
} -result {18 24 30}
test chan-io-29.20 {Implicit flush when buffer is full} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
for {set x 0} {$x < 100} {incr x} {
chan puts $f1 $line
}
set z ""
lappend z [file size $path(test1)]
for {set x 0} {$x < 100} {incr x} {
|
| ︙ | ︙ | |||
2678 2679 2680 2681 2682 2683 2684 |
}
string tolower $x
} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}}
test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| | | | | 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 |
}
string tolower $x
} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}}
test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan flush $f
file size $path(test1)
} -cleanup {
chan close $f
} -result 21
test chan-io-29.29 {Tcl_WriteChars, cr mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
} -result 21
test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
} -result 25
test chan-io-29.31 {Tcl_WriteChars, background flush} -setup {
file delete $path(pipe)
file delete $path(output)
|
| ︙ | ︙ | |||
3176 3177 3178 3179 3180 3181 3182 |
chan close $f
} -result {abc def 0 {} 1 {} 1}
test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | | | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 |
chan close $f
} -result {abc def 0 {} 1 {} 1}
test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result "abc def 0 \x1Aghi 0 qrs 0 {} 1"
test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
set x [chan gets $f]
lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {1 1 {} 1}
test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
set x [chan gets $f]
lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
|
| ︙ | ︙ | |||
3730 3731 3732 3733 3734 3735 3736 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | | | 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1"
test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1"
test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
|
| ︙ | ︙ | |||
3832 3833 3834 3835 3836 3837 3838 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
|
| ︙ | ︙ | |||
4217 4218 4219 4220 4221 4222 4223 |
set x 24
chan gets $f x(0)
} -returnCodes error -cleanup {
chan close $f
} -result {can't set "x(0)": variable isn't array}
test chan-io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
| | | | | 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 |
set x 24
chan gets $f x(0)
} -returnCodes error -cleanup {
chan close $f
} -result {can't set "x(0)": variable isn't array}
test chan-io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
chan configure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 100} {incr y} {chan puts $f $x}
chan close $f
set f [open $path(test3) r]
chan configure $f -translation lf
for {set y 0} {$y < 100} {incr y} {chan gets $f}
chan close $f
set y
} 100
test chan-io-33.9 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
chan configure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 200} {incr y} {chan puts $f $x}
chan close $f
set f [open $path(test3) r]
chan configure $f -translation lf
for {set y 0} {$y < 200} {incr y} {chan gets $f}
chan close $f
set y
} 200
test chan-io-33.10 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
chan configure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 300} {incr y} {chan puts $f $x}
chan close $f
set f [open $path(test3) r]
chan configure $f -translation lf
for {set y 0} {$y < 300} {incr y} {chan gets $f}
|
| ︙ | ︙ | |||
4268 4269 4270 4271 4272 4273 4274 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.2 {Tcl_Seek to offset from start} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | | | | | 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.2 {Tcl_Seek to offset from start} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 10 start
chan tell $f1
} -cleanup {
chan close $f1
} -result 10
test chan-io-34.3 {Tcl_Seek to end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 0 end
chan tell $f1
} -cleanup {
chan close $f1
} -result 54
test chan-io-34.4 {Tcl_Seek to offset from end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
chan tell $f1
} -cleanup {
chan close $f1
} -result 44
test chan-io-34.5 {Tcl_Seek to offset from current position} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 10 current
chan seek $f1 10 current
chan tell $f1
} -cleanup {
chan close $f1
} -result 20
test chan-io-34.6 {Tcl_Seek to offset from end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
list [chan tell $f1] [chan read $f1]
} -cleanup {
chan close $f1
} -result {44 {rstuvwxyz
}}
test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
set c1 [chan tell $f1]
set r1 [chan read $f1 5]
|
| ︙ | ︙ | |||
4364 4365 4366 4367 4368 4369 4370 |
} -returnCodes error -cleanup {
chan close $pipe
} -match glob -result {error during seek on "*": invalid argument}
test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
| < | 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 |
} -returnCodes error -cleanup {
chan close $pipe
} -match glob -result {error during seek on "*": invalid argument}
test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
chan close $f
set f [open $path(test3) RDWR]
set x [chan read $f 1]
chan seek $f 3
lappend x [chan read $f 1]
chan seek $f 0 start
|
| ︙ | ︙ | |||
4412 4413 4414 4415 4416 4417 4418 |
chan seek $f 2
set x [chan gets $f]
chan close $f
list $x [viewFile test3]
} "zzy xyzzy"
test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
| | | | 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 |
chan seek $f 2
set x [chan gets $f]
chan close $f
list $x [viewFile test3]
} "zzy xyzzy"
test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
chan configure $f -translation lf
chan puts $f xyz\n123
chan close $f
set f [open $path(test3) a+]
chan configure $f -translation lf
chan puts $f xyzzy
chan flush $f
set x [chan tell $f]
chan seek $f -4 cur
set y [chan gets $f]
chan close $f
list $x [viewFile test3] $y
|
| ︙ | ︙ | |||
4439 4440 4441 4442 4443 4444 4445 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 0 end
chan tell $f1
} -cleanup {
chan close $f1
} -result 54
test chan-io-34.15 {Tcl_Tell combined with seeking} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 10 start
set c1 [chan tell $f1]
chan seek $f1 10 current
|
| ︙ | ︙ | |||
4484 4485 4486 4487 4488 4489 4490 |
chan close $f1
set c
} -1
test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup {
file delete $path(test2)
} -body {
set f [open $path(test2) w]
| | | | 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 |
chan close $f1
set c
} -1
test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup {
file delete $path(test2)
} -body {
set f [open $path(test2) w]
chan configure $f -translation lf
chan puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
chan close $f
set f [open $path(test2)]
chan configure $f -translation lf
set x [chan tell $f]
chan read $f 3
lappend x [chan tell $f]
chan seek $f 2
lappend x [chan tell $f]
chan seek $f 10 current
lappend x [chan tell $f]
chan seek $f 0 end
lappend x [chan tell $f]
} -cleanup {
chan close $f
} -result {0 3 2 12 30}
test chan-io-34.19 {Tcl_Tell combined with opening in append mode} -body {
set f [open $path(test3) w]
chan configure $f -translation lf
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan close $f
set f [open $path(test3) a]
chan tell $f
} -cleanup {
chan close $f
|
| ︙ | ︙ | |||
4531 4532 4533 4534 4535 4536 4537 |
lappend l [chan tell $f]
} -cleanup {
chan close $f
} -result {29 39 40 447}
test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup {
file delete $path(test3)
set l ""
| | | | 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 |
lappend l [chan tell $f]
} -cleanup {
chan close $f
} -result {29 39 40 447}
test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup {
file delete $path(test3)
set l ""
} -constraints {largefileSupport extensive} -body {
set f [open $path(test3) w]
chan configure $f -translation binary
lappend l [chan tell $f]
chan puts -nonewline $f abcdef
lappend l [chan tell $f]
chan flush $f
lappend l [chan tell $f]
# 4GB offset!
chan seek $f 0x100000000
|
| ︙ | ︙ | |||
4730 4731 4732 4733 4734 4735 4736 |
} -cleanup {
chan close $f
} -result {10 8 1}
test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| | | | | | | | 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 |
} -cleanup {
chan close $f
} -result {10 8 1}
test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {21 8 1}
test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
|
| ︙ | ︙ | |||
5074 5075 5076 5077 5078 5079 5080 |
chan close $f1
} -result {0 21}
test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup {
file delete $path(test1)
set l ""
} -body {
set f1 [open $path(test1) w]
| | | 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 |
chan close $f1
} -result {0 21}
test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup {
file delete $path(test1)
set l ""
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -buffering none
chan puts -nonewline $f1 hello
lappend l [file size $path(test1)]
chan puts -nonewline $f1 hello
lappend l [file size $path(test1)]
chan configure $f1 -buffering full
chan puts -nonewline $f1 hello
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
5174 5175 5176 5177 5178 5179 5180 |
} -cleanup {
chan close $f
} -result 40000
test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| | | | | | 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 |
} -cleanup {
chan close $f
} -result 40000
test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f \xE7\x89\xA6
chan close $f
set f [open $path(test1) r]
chan configure $f -encoding utf-8
chan read $f
} -cleanup {
chan close $f
} -result 牦
test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f \xE7\x89\xA6
chan close $f
set f [open $path(test1) r]
chan configure $f -encoding utf-8
chan read $f
} -cleanup {
chan close $f
} -result 牦
test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup {
file delete $path(test1)
set f [open $path(test1) w]
} -body {
chan configure $f -encoding foobar
} -returnCodes error -cleanup {
chan close $f
} -result {unknown encoding "foobar"}
test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup {
variable x {}
} -constraints {stdio fileevent} -body {
set f [openpipe r+ $path(cat)]
chan configure $f -encoding iso8859-1
chan puts -nonewline $f \xE7
chan flush $f
chan configure $f -encoding utf-8 -blocking 0
chan event $f readable [namespace code { lappend x [chan read $f] }]
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
chan configure $f -encoding utf-8
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
chan configure $f -encoding iso8859-1
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result "{} timeout {} timeout \xE7 timeout"
|
| ︙ | ︙ | |||
5319 5320 5321 5322 5323 5324 5325 |
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
lappend l [chan configure $sock -eofchar] \
[chan configure $sock -translation]
} -cleanup {
chan close $sock
} -result {{} auto}
test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\
| | | 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 |
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
lappend l [chan configure $sock -eofchar] \
[chan configure $sock -translation]
} -cleanup {
chan close $sock
} -result {{} auto}
test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\
writable so we can't change -eofchar or -translation} -setup {
set l [list]
} -body {
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
chan configure $sock -eofchar D -translation lf
lappend l [chan configure $sock -eofchar] \
[chan configure $sock -translation]
} -cleanup {
|
| ︙ | ︙ | |||
5371 5372 5373 5374 5375 5376 5377 |
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode) & 0o777}]
} -result [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
| < < | | 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 5387 5388 5389 |
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode) & 0o777}]
} -result [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
chan puts $f xyzzy
chan close $f
set f [open $path(test3) {WRONLY CREAT}]
chan puts -nonewline $f "ab"
chan close $f
set f [open $path(test3) r]
chan gets $f
} -cleanup {
chan close $f
} -result abzzy
test chan-io-40.5 {POSIX open access modes: APPEND} -setup {
file delete $path(test3)
set x ""
} -body {
set f [open $path(test3) w]
chan configure $f -translation lf
chan puts $f xyzzy
chan close $f
set f [open $path(test3) {WRONLY APPEND}]
chan configure $f -translation lf
chan puts $f "new line"
chan seek $f 0
chan puts $f "abc"
|
| ︙ | ︙ | |||
5417 5418 5419 5420 5421 5422 5423 |
chan close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test chan-io-40.7 {POSIX open access modes: EXCL} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) {WRONLY CREAT EXCL}]
| < | 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 |
chan close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test chan-io-40.7 {POSIX open access modes: EXCL} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) {WRONLY CREAT EXCL}]
chan puts $f "A test line"
chan close $f
viewFile test3
} -result {A test line}
test chan-io-40.8 {POSIX open access modes: TRUNC} -setup {
file delete $path(test3)
} -body {
|
| ︙ | ︙ | |||
5468 5469 5470 5471 5472 5473 5474 |
test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test chan-io-40.13 {POSIX open access modes: WRONLY} -body {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
| < | 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 |
test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test chan-io-40.13 {POSIX open access modes: WRONLY} -body {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
chan puts -nonewline $f "ab"
chan seek $f 0 current
set x [list [catch {chan gets $f} msg] $msg]
chan close $f
lappend x [viewFile test3]
} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy}
test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
|
| ︙ | ︙ | |||
5501 5502 5503 5504 5505 5506 5507 |
} -cleanup {
file delete ./~ ;# ./ because don't want to delete home in case of bugs!
cd $curdir
} -result 1
test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event foo
| | | | 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 |
} -cleanup {
file delete ./~ ;# ./ because don't want to delete home in case of bugs!
cd $curdir
} -result 1
test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event foo
} -returnCodes error -result {wrong # args: should be "chan event channel event ?script?"}
test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event foo bar baz q
} -returnCodes error -result {wrong # args: should be "chan event channel event ?script?"}
test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event gorp readable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event gorp writable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
|
| ︙ | ︙ | |||
5806 5807 5808 5809 5810 5811 5812 |
after cancel $timer
testfevent cmd {chan close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test chan-io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
| | | | | | | | | | | | | | | | 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 |
after cancel $timer
testfevent cmd {chan close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test chan-io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
variable x 0
after 100 {set x triggered}
vwait [namespace which -variable x]
set x
}
} {triggered}
test chan-io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
set x 0
after 10 {lappend x timer}
after 30
set result $x
update idletasks
lappend result $x
update
lappend result $x
}
} {0 0 {0 timer}}
test chan-io-47.1 {chan event vs multiple interpreters} -setup {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set x {}
} -constraints {testfevent fileevent} -body {
chan event $f readable {script 1}
testfevent create
testfevent share $f2
testfevent cmd "chan event $f2 readable {script 2}"
chan event $f3 readable {sript 3}
lappend x [chan event $f2 readable]
testfevent delete
lappend x [chan event $f readable] [chan event $f2 readable] \
[chan event $f3 readable]
} -cleanup {
chan close $f
chan close $f2
chan close $f3
} -result {{} {script 1} {} {sript 3}}
test chan-io-47.2 {deleting chan event on interpreter delete} -setup {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
} -constraints {testfevent fileevent} -body {
chan event $f readable {script 1}
testfevent create
testfevent share $f2
testfevent share $f3
testfevent cmd "chan event $f2 readable {script 2}
chan event $f3 readable {script 3}"
chan event $f4 readable {script 4}
testfevent delete
list [chan event $f readable] [chan event $f2 readable] \
[chan event $f3 readable] [chan event $f4 readable]
} -cleanup {
chan close $f
chan close $f2
|
| ︙ | ︙ | |||
6709 6710 6711 6712 6713 6714 6715 |
set s0 [chan copy $f1 $f2]
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {($s1 == $s2) && ($s0 == $s1)} {
| | | 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 |
set s0 [chan copy $f1 $f2]
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {($s1 == $s2) && ($s0 == $s1)} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.4 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
|
| ︙ | ︙ | |||
6731 6732 6733 6734 6735 6736 6737 |
lappend result [file size $path(test1)]
} -result {0 0 40}
test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
| | | | | | | | | | | | | | | | | 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 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 |
lappend result [file size $path(test1)]
} -result {0 0 40}
test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup {
file delete $path(test1)
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup {
file delete $path(test1)
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.6 {TclCopyChannel} -setup {
file delete $path(test1)
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]]
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {($s1 == $s2) && ($s0 == $s1)} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -cleanup {
chan close $f1
chan close $f2
} -result {0 0 ok}
test chan-io-52.8 {TclCopyChannel} -setup {
|
| ︙ | ︙ | |||
6870 6871 6872 6873 6874 6875 6876 |
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy} -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
chan configure $in -encoding koi8-r -translation lf
| < < | 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 |
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy} -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
chan configure $in -encoding koi8-r -translation lf
chan configure $out -translation binary
chan copy $in $out
file size $path(utf8-fcopy.txt)
} -cleanup {
chan close $in
chan close $out
unset in out
} -returnCodes 1 -match glob -result {error writing "*":\
invalid or incomplete multibyte or wide character}
test chan-io-52.11 {TclCopyChannel & encodings} -setup {
set f [open $path(utf8-fcopy.txt) w]
fconfigure $f -encoding utf-8 -translation lf
puts $f АА
close $f
} -constraints {fcopy} -body {
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
chan configure $in -translation binary
chan configure $out -encoding koi8-r -translation lf -profile strict
catch {chan copy $in $out} cres copts
return $cres
} -cleanup {
if {$in in [chan names]} {
close $in
|
| ︙ | ︙ | |||
6933 6934 6935 6936 6937 6938 6939 |
variable s0
vwait [namespace which -variable s0]
chan close $f1
chan close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {($s1 == $s2) && ($s0 == $s1)} {
| | | 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 |
variable s0
vwait [namespace which -variable s0]
chan close $f1
chan close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {($s1 == $s2) && ($s0 == $s1)} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-53.3 {CopyData: background read underflow} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints {stdio unix fcopy} -body {
|
| ︙ | ︙ | |||
7067 7068 7069 7070 7071 7072 7073 |
variable fcopyTestCount
incr fcopyTestCount $bytes
if {[string length $error]} {
set fcopyTestDone 1
} elseif {[chan eof $in]} {
set fcopyTestDone 0
} else {
| | | | | | 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 |
variable fcopyTestCount
incr fcopyTestCount $bytes
if {[string length $error]} {
set fcopyTestDone 1
} elseif {[chan eof $in]} {
set fcopyTestDone 0
} else {
# Delay next chan copy to wait for size>0 input bytes
after 100 [list chan copy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]]
}
}
test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
} -constraints {stdio fcopy} -body {
set fcopyTestCount 0
set f1 [open $path(pipe) w]
chan puts $f1 {
# Write 10 bytes / 10 msec
proc Write {count} {
chan puts -nonewline "1234567890"
if {[incr count -1]} {
after 10 [list Write $count]
} else {
set ::ready 1
}
}
chan configure stdout -buffering none
Write 345 ;# 3450 bytes ~3.45 sec
vwait ready
exit 0
}
|
| ︙ | ︙ | |||
7237 7238 7239 7240 7241 7242 7243 |
catch {after cancel $token}
set ::forever
} -cleanup {
chan close $pipe
rename ::done {}
if {[testConstraint win]} {
after 1000; # Allow Windows time to figure out that the
| | | 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 |
catch {after cancel $token}
set ::forever
} -cleanup {
chan close $pipe
rename ::done {}
if {[testConstraint win]} {
after 1000; # Allow Windows time to figure out that the
# process is gone
}
catch {close $out}
catch {removeFile out}
catch {removeFile err}
catch {unset ::forever}
} -result OK
test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup {
|
| ︙ | ︙ | |||
7278 7279 7280 7281 7282 7283 7284 |
chan puts stderr 2COPY
}
chan puts stderr ...
}
chan puts stderr SRV
set l {}
set srv [socket -server new -myaddr 127.0.0.1 0]
| | | 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 |
chan puts stderr 2COPY
}
chan puts stderr ...
}
chan puts stderr SRV
set l {}
set srv [socket -server new -myaddr 127.0.0.1 0]
set port [lindex [chan configure $srv -sockname] 2]
chan puts stderr WAITING
chan event stdin readable bye
puts "OK $port"
vwait forever
}
# wait for OK from server.
lassign [chan gets $pipe] ok port
|
| ︙ | ︙ |
Added tests/clock-ivm.test.
> > > > > > > > | 1 2 3 4 5 6 7 8 |
# clock-ivm.test --
#
# This test file covers the 'clock' command using inverted validity mode.
#
# See the file "clock.test" for more information.
::tcl::unsupported::clock::configure -valid [expr {![::tcl::unsupported::clock::configure -valid]}]
source [file join [file dirname [info script]] clock.test]
|
Changes to tests/clock.test.
more than 10,000 changes
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# File permissions broken on wsl without some "exotic" wsl configuration
| > > > > > > > > > > > > > > > > > > > > | 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 |
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint time64bit [expr {
([llength [info command testsize]] ?
[testsize st_mtime] : $::tcl_platform(pointerSize)) >= 8
}]
testConstraint filetime64bit [expr {
[testConstraint time64bit] && (
![testConstraint unix] || [apply {{} {
# check whether disk may have 2038 problem, see [fd91b0ca09cb171f]:
set fn [makeFile "" foo.text]
if {[catch {
exec sh -c "TZ=:UTC LC_TIME=en_US touch -ma -t '207006290000' '$fn' && TZ=:UTC LC_TIME=en_US ls -l '$fn'"
} res]} {
#puts "Check constraint failed:\t$res"
set res {}
}
removeFile $fn
regexp {\mJun\s+29\s+2070\M} $res
}}]
)
}]
testConstraint linkDirectory [expr {
![testConstraint win] ||
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# File permissions broken on wsl without some "exotic" wsl configuration
|
| ︙ | ︙ | |||
193 194 195 196 197 198 199 |
# Maps utf-{16,32}{le,be} to utf-16, utf-32 and
# others to "". Used to test utf-16, utf-32 based
# on system endianness
proc endianUtf {enc} {
if {$::tcl_platform(byteOrder) eq "littleEndian"} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# Maps utf-{16,32}{le,be} to utf-16, utf-32 and
# others to "". Used to test utf-16, utf-32 based
# on system endianness
proc endianUtf {enc} {
if {$::tcl_platform(byteOrder) eq "littleEndian"} {
set endian le
} else {
set endian be
}
if {$enc eq "utf-16$endian" || $enc eq "utf-32$endian"} {
return [string range $enc 0 5]
}
return ""
}
#
# Check errors for invalid number of arguments
proc badnumargs {id cmd cmdargs} {
variable numargErrors
test $id.a "Syntax error: $cmd $cmdargs" \
-body [list {*}$cmd {*}$cmdargs] \
-result $numargErrors($cmd) \
-match regexp \
-returnCodes error
test $id.b "Syntax error: $cmd (byte compiled)" \
-setup [list proc compiled_proc {} [list {*}$cmd {*}$cmdargs]] \
-body {compiled_proc} \
-cleanup {rename compiled_proc {}} \
-result $numargErrors($cmd) \
-match regexp \
-returnCodes error
}
# Wraps tests resulting in unknown encoding errors
proc unknownencodingtest {id cmd} {
set result "unknown encoding \"[lindex $cmd end-1]\""
test $id.a "Unknown encoding error: $cmd" \
-body [list encoding {*}$cmd] \
-result $result \
-returnCodes error
test $id.b "Syntax error: $cmd (byte compiled)" \
-setup [list proc encoding_test {} [list encoding {*}$cmd]] \
-body {encoding_test} \
-cleanup {rename encoding_test {}} \
-result $result \
-returnCodes error
}
# Wraps tests for conversion, successful or not.
# Really more general than just for encoding conversion.
proc testconvert {id body result args} {
test $id.a $body \
-body $body \
-result $result \
{*}$args
dict append args -setup \n[list proc compiled_script {} $body]
dict append args -cleanup "\nrename compiled_script {}"
test $id.b "$body (byte compiled)" \
-body {compiled_script} \
-result $result \
{*}$args
}
# Wrapper to verify encoding convert{to,from} ?-profile?
# Generates tests for compiled and uncompiled implementation.
# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be}
# The enc and profile are appended to id to generate the test id
proc testprofile {id converter enc profile data result args} {
testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args
if {[set enc2 [endianUtf $enc]] ne ""} {
# If utf{16,32}-{le,be}, also do utf{16,32}
testconvert $id.$enc2.$profile [list encoding $converter -profile $profile $enc2 $data] $result {*}$args
}
# If this is the default profile, generate a test without specifying profile
if {$profile eq $::encDefaultProfile} {
testconvert $id.$enc.default [list encoding $converter $enc $data] $result {*}$args
if {[set enc2 [endianUtf $enc]] ne ""} {
# If utf{16,32}-{le,be}, also do utf{16,32}
testconvert $id.$enc2.default [list encoding $converter $enc2 $data] $result {*}$args
}
}
}
# Wrapper to verify encoding convert{to,from} -failindex ?-profile?
# Generates tests for compiled and uncompiled implementation.
# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be}
# The enc and profile are appended to id to generate the test id
proc testfailindex {id converter enc data result failidx {profile default}} {
testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc [list $data]\] \[set idx\]" [list $result $failidx]
if {[set enc2 [endianUtf $enc]] ne ""} {
# If utf{16,32}-{le,be}, also do utf{16,32}
testconvert $id.$enc2.$profile "list \[encoding $converter -profile $profile -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx]
}
# If this is the default profile, generate a test without specifying profile
if {$profile eq $::encDefaultProfile} {
testconvert $id.$enc.default "list \[encoding $converter -failindex idx $enc [list $data]\] \[set idx]" [list $result $failidx]
if {[set enc2 [endianUtf $enc]] ne ""} {
# If utf{16,32}-{le,be}, also do utf{16,32}
testconvert $id.$enc2.default "list \[encoding $converter -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx]
}
}
}
test cmdAH-4.1.1 {encoding} -returnCodes error -body {
encoding
} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test cmdAH-4.1.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
|
| ︙ | ︙ | |||
358 359 360 361 362 363 364 |
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc A]
set suffix_bytes [encoding convertto $enc B]
foreach profile $encProfiles {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc A]
set suffix_bytes [encoding convertto $enc B]
foreach profile $encProfiles {
testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes $str
testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes $str$suffix
testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes $prefix$str
testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix
}
}
# convertfrom ?-profile? : invalid byte sequences
foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes {
if {"knownBug" in $ctrl} continue
set bytes [binary format H* $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]
set result [list $str]
# TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch
# so glob it out in error message pattern for now.
set errorWithoutPrefix [list "unexpected byte sequence starting at index $failidx: *" -returnCodes error -match glob]
set errorWithPrefix [list "unexpected byte sequence starting at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob]
if {$ctrl eq {} || "solo" in $ctrl} {
if {$failidx == -1} {
set result [list $str]
} else {
set result $errorWithoutPrefix
}
testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes {*}$result
}
if {$ctrl eq {} || "lead" in $ctrl} {
if {$failidx == -1} {
set result [list $str$suffix]
} else {
set result $errorWithoutPrefix
}
testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes {*}$result
}
if {$ctrl eq {} || "tail" in $ctrl} {
if {$failidx == -1} {
set result [list $prefix$str]
} else {
set result $errorWithPrefix
}
testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes {*}$result
}
if {$ctrl eq {} || "middle" in $ctrl} {
if {$failidx == -1} {
set result [list $prefix$str$suffix]
} else {
set result $errorWithPrefix
}
testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes {*}$result
}
}
# convertfrom -failindex ?-profile? - valid data
foreach {enc str hex ctrl comment} $encValidStrings {
if {"knownBug" in $ctrl} continue
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]
foreach profile $encProfiles {
testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str -1 $profile
testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $str$suffix -1 $profile
testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $prefix$str -1 $profile
testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix -1 $profile
}
}
# convertfrom -failindex ?-profile? - invalid data
foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes {
if {"knownBug" in $ctrl} 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 {$ctrl eq {} || "solo" in $ctrl} {
testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str $failidx $profile
}
if {$ctrl eq {} || "lead" in $ctrl} {
if {$failidx == -1} {
# If success expected
set result $str$suffix
} else {
# Failure expected
set result ""
}
testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $result $failidx $profile
}
if {$ctrl eq {} || "tail" in $ctrl} {
set expected_failidx $failidx
if {$failidx == -1} {
# If success expected
set result $prefix$str
} else {
# Failure expected
set result $prefix
incr expected_failidx $prefixLen
}
testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $result $expected_failidx $profile
}
if {$ctrl eq {} || "middle" in $ctrl} {
set expected_failidx $failidx
if {$failidx == -1} {
# If success expected
set result $prefix$str$suffix
} else {
# Failure expected
set result $prefix
incr expected_failidx $prefixLen
}
testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $result $expected_failidx $profile
}
}
#
# encoding convertto 4.4.*
badnumargs cmdAH-4.4.1 {encoding convertto} {}
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc A]
set suffix_bytes [encoding convertto $enc B]
foreach profile $encProfiles {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc A]
set suffix_bytes [encoding convertto $enc B]
foreach profile $encProfiles {
testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str $bytes
testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix $bytes$suffix_bytes
testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str $prefix_bytes$bytes
testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes
}
}
# convertto ?-profile? : invalid byte sequences
foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
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]
set result [list $bytes]
# TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch
# so glob it out in error message pattern for now.
set errorWithoutPrefix [list "unexpected character at index $failidx: *" -returnCodes error -match glob]
set errorWithPrefix [list "unexpected character at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob]
if {$ctrl eq {} || "solo" in $ctrl} {
if {$failidx == -1} {
set result [list $bytes]
} else {
set result $errorWithoutPrefix
}
testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str {*}$result
}
if {$ctrl eq {} || "lead" in $ctrl} {
if {$failidx == -1} {
set result [list $bytes$suffix_bytes]
} else {
set result $errorWithoutPrefix
}
testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix {*}$result
}
if {$ctrl eq {} || "tail" in $ctrl} {
if {$failidx == -1} {
set result [list $prefix_bytes$bytes]
} else {
set result $errorWithPrefix
}
testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str {*}$result
}
if {$ctrl eq {} || "middle" in $ctrl} {
if {$failidx == -1} {
set result [list $prefix_bytes$bytes$suffix_bytes]
} else {
set result $errorWithPrefix
}
testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix {*}$result
}
}
# convertto -failindex ?-profile? - valid data
foreach {enc str hex ctrl comment} $encValidStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc A]
set suffix_bytes [encoding convertto $enc B]
foreach profile $encProfiles {
testfailindex cmdAH-4.4.14.$enc.$printable.solo convertto $enc $str $bytes -1 $profile
testfailindex cmdAH-4.4.14.$enc.$printable.lead convertto $enc $str$suffix $bytes$suffix_bytes -1 $profile
testfailindex cmdAH-4.4.14.$enc.$printable.tail convertto $enc $prefix$str $prefix_bytes$bytes -1 $profile
testfailindex cmdAH-4.4.14.$enc.$printable.middle convertto $enc $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes -1 $profile
}
}
# convertto -failindex ?-profile? - invalid data
foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefixLen [string length [encoding convertto $enc $prefix]]
if {$ctrl eq {} || "solo" in $ctrl} {
testfailindex cmdAH-4.4.14.$printable.solo convertto $enc $str $bytes $failidx $profile
}
if {$ctrl eq {} || "lead" in $ctrl} {
if {$failidx == -1} {
# If success expected
set result $bytes$suffix
} else {
# Failure expected
set result ""
}
testfailindex cmdAH-4.4.14.$printable.lead convertto $enc $str$suffix $result $failidx $profile
}
if {$ctrl eq {} || "tail" in $ctrl} {
set expected_failidx $failidx
if {$failidx == -1} {
# If success expected
set result $prefix$bytes
} else {
# Failure expected
set result $prefix
incr expected_failidx $prefixLen
}
testfailindex cmdAH-4.4.14.$printable.tail convertto $enc $prefix$str $result $expected_failidx $profile
}
if {$ctrl eq {} || "middle" in $ctrl} {
set expected_failidx $failidx
if {$failidx == -1} {
# If success expected
set result $prefix$bytes$suffix
} else {
# 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 {
# 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'}
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 |
test cmdAH-16.1 {Tcl_FileObjCmd: readable} {
-returnCodes error
-body {file readable a b}
-result {wrong # args: should be "file readable name"}
}
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
-constraints testchmod
| | | | | | | | | | | | | | 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 |
test cmdAH-16.1 {Tcl_FileObjCmd: readable} {
-returnCodes error
-body {file readable a b}
-result {wrong # args: should be "file readable name"}
}
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
-constraints testchmod
-setup {testchmod 0o444 $gorpfile}
-body {file readable $gorpfile}
-result 1
}
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {
-constraints {unix notRoot testchmod notWsl}
-setup {testchmod 0o333 $gorpfile}
-body {file readable $gorpfile}
-result 0
}
# writable
test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
-returnCodes error
-body {file writable a b}
-result {wrong # args: should be "file writable name"}
}
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {
-constraints {notRoot testchmod}
-setup {testchmod 0o555 $gorpfile}
-body {file writable $gorpfile}
-result 0
}
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
-constraints testchmod
-setup {testchmod 0o222 $gorpfile}
-body {file writable $gorpfile}
-result 1
}
# executable
removeFile $gorpfile
removeDirectory $dirfile
set dirfile [makeDirectory dir.file]
set gorpfile [makeFile abcde gorp.file]
|
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
# On windows, must be a .exe, .com, etc.
set x {}
set gorpexes {}
foreach ext {exe com cmd bat} {
| | | | | | | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 |
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
# On windows, must be a .exe, .com, etc.
set x {}
set gorpexes {}
foreach ext {exe com cmd bat} {
lappend x [file exe nosuchfile.$ext]
set gorpexe [makeFile foo gorp.$ext]
lappend gorpexes $gorpexe
lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]]
}
set x
} -cleanup {
foreach gorpexe $gorpexes {
removeFile $gorpexe
}
} -result {0 1 1 0 1 1 0 1 1 0 1 1}
test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} {
# Directories are always executable.
file exe $dirfile
} 1
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 |
test cmdAH-24.14.1 {
Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
# 3155760000 is 64-bit Unix time, Wed Jan 01 00:00:00 GMT 2070:
| | | | | 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 |
test cmdAH-24.14.1 {
Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
# 3155760000 is 64-bit Unix time, Wed Jan 01 00:00:00 GMT 2070:
test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit filetime64bit} -setup {
set filename [makeFile "" foo.text]
} -body {
# This test may fail if your system does not have a 64-bit time_t.
# That is to be expected and is not a problem with Tcl.
list [file atime $filename 3155760000] [file atime $filename]
} -cleanup {
removeFile $filename
} -result {3155760000 3155760000}
test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit filetime64bit} -setup {
set filename [makeFile "" foo.text]
} -body {
# This test may fail if your system does not have a 64-bit time_t.
# That is to be expected and is not a problem with Tcl.
list [file mtime $filename 3155760000] [file mtime $filename]
} -cleanup {
file delete -force $filename
} -result {3155760000 3155760000}
# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -setup {
set fn $gorpfile
# prefer temp file to check owner (try to avoid bug [7de2d722bd]):
if {
[info exists ::env(TEMP)] && [file isdirectory $::env(TEMP)] &&
[file dirname $fn] ne [file normalize $::env(TEMP)]
} {
set fn [file join $::env(TEMP)/test-owner-from-tcl.txt]
set fn [makeFile "data" test-owner-from-tcl.txt $::env(TEMP)]
}
# be sure we have really owned this file before trying to check that
# (avoid dependency on admin with UAC and the setting "System objects:
# Default owner for objects created by members of the Administrators group"):
|
| ︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 |
# size
test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body {
file size a b
} -result {wrong # args: should be "file size name"}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
set oldsize [file size $gorpfile]
set f [open $gorpfile a]
| | | 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 |
# size
test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body {
file size a b
} -result {wrong # args: should be "file size name"}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
set oldsize [file size $gorpfile]
set f [open $gorpfile a]
fconfigure $f -translation lf
puts $f "More text"
close $f
expr {[file size $gorpfile] - $oldsize}
} {10}
test cmdAH-27.3 {Tcl_FileObjCmd: size} {
list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 |
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc memusage {} {
set fd [open /proc/[pid]/statm]
set line [gets $fd]
if {[llength $line] != 7} {
| | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc memusage {} {
set fd [open /proc/[pid]/statm]
set line [gets $fd]
if {[llength $line] != 7} {
error "Unexpected /proc/pid/statm format"
}
set result [lindex $line 5]
close $fd
return $result
}
testConstraint hasMemUsage [expr {![catch {memusage}]}]
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
}}
} -result {1 {can't set "x": variable is array} a}
test cmdIL-6.12 {lassign command - memory leak testing} -setup {
unset -nocomplain x y
set x(x) {}
set y FAIL
proc getbytes {} {
| | | | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
}}
} -result {1 {can't set "x": variable is array} a}
test cmdIL-6.12 {lassign command - memory leak testing} -setup {
unset -nocomplain x y
set x(x) {}
set y FAIL
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
}
proc stress {} {
global x y
lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y y y y y y
catch {lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y x}
catch {lassign {} x}
}
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
list [catch {$lassign a y x} msg] $msg $y
}}
} -result {1 {can't set "x": variable is array} a}
test cmdIL-6.24 {lassign command - memory leak testing} -setup {
set x(x) {}
set y FAIL
proc getbytes {} {
| | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
list [catch {$lassign a y x} msg] $msg $y
}}
} -result {1 {can't set "x": variable is array} a}
test cmdIL-6.24 {lassign command - memory leak testing} -setup {
set x(x) {}
set y FAIL
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
}
proc stress {} {
global x y
set lassign lassign
$lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y y y y y y
catch {$lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y x}
catch {$lassign {} x}
|
| ︙ | ︙ | |||
865 866 867 868 869 870 871 |
lremove {a b c d e} 1 3 1 4 0
} -result {c}
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
| | | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 |
lremove {a b c d e} 1 3 1 4 0
} -result {c}
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/cmdInfo.test.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 |
test cmdinfo-5.1 {Names for commands created when inside namespaces} \
{testcmdtoken} {
# create namespace cmdInfoNs1
namespace eval cmdInfoNs1 {} ;# creates namespace cmdInfoNs1
# create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it
set x [namespace eval cmdInfoNs1::cmdInfoNs2 {
| | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
test cmdinfo-5.1 {Names for commands created when inside namespaces} \
{testcmdtoken} {
# create namespace cmdInfoNs1
namespace eval cmdInfoNs1 {} ;# creates namespace cmdInfoNs1
# create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it
set x [namespace eval cmdInfoNs1::cmdInfoNs2 {
# the following creates a cmd in the global namespace
testcmdtoken create testCmd
}]
set y [testcmdtoken name $x]
rename ::testCmd newTestCmd
lappend y {*}[testcmdtoken name $x]
} {testCmd ::testCmd newTestCmd ::newTestCmd}
test cmdinfo-6.1 {Names for commands created when outside namespaces} \
|
| ︙ | ︙ |
Changes to tests/cmdMZ.test.
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
split {}
} {}
test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} {
split { }
} {{} {} {} {}}
test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} {
apply {{} {
| | | | | | | | | > | | | | > > > | 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 |
split {}
} {}
test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} {
split { }
} {{} {} {} {}}
test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} {
apply {{} {
set x {}
foreach f [split {]\n} {}] {
append x $f
}
return $x
}}
} {]\n}
test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
apply {{} {
set x ab\x00c
set y [split $x {}]
binary scan $y c* z
return $z
}}
} {97 32 98 32 0 32 99}
test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} {
split "a0ab1b2bbb3\x00c4" ab\x00c
} {{} 0 {} 1 2 {} {} 3 {} 4}
test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
# if not UTF-8 aware, result is "a {} {} b qwå {} N wq"
split "a乎b qw幎N wq" " 乎"
} "a b qw幎N wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
set stime [clock microseconds]
set usec [expr {$msec * 1000}]
set etime [expr {$stime + $usec}]
while {[set tm [clock microseconds]] < $etime} {
# don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise):
# after 0
if {$tm < $stime} { # avoid too long delays by backwards time jumps, simply skip test
tcltest::Skip "time-jump?"
}
}
}
_nrt_sleep 0; # warm up (clock, compile, etc)
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
|
| ︙ | ︙ | |||
400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measurement} -body {
set m1 [timerate {_nrt_sleep 0.01} 50]
set m2 [timerate {_nrt_sleep 1.00} 50]
list [list \
[expr {[lindex $m1 0] < [lindex $m2 0]}] \
[expr {[lindex $m1 0] < 100}] \
[expr {[lindex $m2 0] > 100}] \
[expr {[lindex $m1 2] > 500}] \
[expr {[lindex $m2 2] < 500}] \
[expr {[lindex $m1 4] > 10000}] \
| > > > | 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measurement} -body {
set m1 [timerate {_nrt_sleep 0.01} 50]
set m2 [timerate {_nrt_sleep 1.00} 50]
if {[testConstraint valgrind] && ([lindex $m1 0] >= 100 || [lindex $m1 2] <= 500)} {
tcltest::Skip "too-slow-by-valgrind"
}
list [list \
[expr {[lindex $m1 0] < [lindex $m2 0]}] \
[expr {[lindex $m1 0] < 100}] \
[expr {[lindex $m2 0] > 100}] \
[expr {[lindex $m1 2] > 500}] \
[expr {[lindex $m2 2] < 500}] \
[expr {[lindex $m1 4] > 10000}] \
|
| ︙ | ︙ |
Changes to tests/compExpr-old.test.
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
return $c
}
proc hello_world {} {
global a
set a ""
set L1 [set l0 [set h_1 [set q 0]]]
for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0]
| | | | | | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
return $c
}
proc hello_world {} {
global a
set a ""
set L1 [set l0 [set h_1 [set q 0]]]
for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0]
:!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])]
?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3?
[incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]]
:[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2
?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]}
expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]}
}
set a
}
proc 12days {a b c} {
global xxx
expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
expr 2***3|6
} -returnCodes error -match glob -result *
test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
| | | | | | 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 |
expr 2***3|6
} -returnCodes error -match glob -result *
test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of "^"}}
test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "^"}}
test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} -body {
expr x==3
} -returnCodes error -match glob -result *
test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2***3&6
} -returnCodes error -match glob -result *
test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2&x
} -returnCodes error -match glob -result *
test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of "&"}}
test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "&"}}
test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} -body {
expr x>3
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
| | | | | | 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 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of ">>"}}
test compExpr-old-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "<<"}}
test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6
test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} -body {
expr x*3
} -returnCodes error -match glob -result *
test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} -body {
expr 2***3+6
} -returnCodes error -match glob -result *
test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body {
expr 2-x
} -returnCodes error -match glob -result *
test compExpr-old-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {cannot use non-numeric string "xx" as right operand of "+"}}
test compExpr-old-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "-"}}
test compExpr-old-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint {
list [catch {expr {2.3/0.0}} msg] $msg
} {0 Inf}
test compExpr-old-11.13b {CompileAddExpr: runtime error} !ieeeFloatingPoint {
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
expr 2*3%%6
} -returnCodes error -match glob -result *
test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*x
} -returnCodes error -match glob -result *
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
| | | | | | 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 |
expr 2*3%%6
} -returnCodes error -match glob -result *
test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*x
} -returnCodes error -match glob -result *
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {cannot use non-numeric string "xx" as right operand of "*"}}
test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "/"}}
test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83
test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} -body {
expr ~x
} -returnCodes error -match glob -result *
test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body {
expr !1.x
set msg
} -returnCodes error -match glob -result *
test compExpr-old-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
} {1 {cannot use non-numeric string "xx" as operand of "~"}}
test compExpr-old-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
} {1 {cannot use floating-point value "4.0" as operand of "~"}}
test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
expr $a
} 27
test compExpr-old-13.14 {CompileUnaryExpr: just primary expr} {
expr double(27)
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
} -returnCodes error -match glob -result *
test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
| | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
} -returnCodes error -match glob -result *
test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
set i {}
}
set i
} {}
test compExpr-old-16.2 {GetToken: check for string literal in braces} {
expr {{1}}
} {1}
|
| ︙ | ︙ | |||
619 620 621 622 623 624 625 |
} 11
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
test compExpr-old-19.1 {expr and interpreter result object resetting} {
proc p {} {
| | | | | | | | | | | | | 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 |
} 11
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
test compExpr-old-19.1 {expr and interpreter result object resetting} {
proc p {} {
set t 10.0
set x 2.0
set dx 0.2
set f {$dx-$x/10}
set g {-$x/5}
set center 1.0
set x [expr $x-$center]
set dx [expr $dx+$g]
set x [expr $x+$f+$center]
set x [expr $x+$f+$center]
set y [expr round($x)]
}
p
} 3
# cleanup
if {[info exists a]} {
unset a
}
::tcltest::cleanupTests
return
|
Changes to tests/compExpr.test.
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
} -cleanup {
unset end i tmp
rename getbytes {}
} -result 0
test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setup {
proc getbytes {} {
| | | | | | | | | | | 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 |
} -cleanup {
unset end i tmp
rename getbytes {}
} -result 0
test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setup {
proc getbytes {} {
set lines [split [memory info] \n]
lindex $lines 3 3
}
} -body {
set i 5
set end [getbytes]
while {[incr i -1]} {
expr ${i}000
set tmp $end
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
unset end i tmp
rename getbytes {}
} -result 0
proc extract {opcodes descriptor} {
set instructions [dict values [dict get $descriptor instructions]]
return [lmap i $instructions {
if {[lindex $i 0] in $opcodes} {string cat $i} else continue
}]
}
test compExpr-8.1 {TIP 582: expression comments} -setup {} -body {
extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
$abc
# + $def
+ $ghi
}}]
} -result {loadStk loadStk add}
test compExpr-8.2 {TIP 582: expression comments} -setup {} -body {
extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
$abc
# + $def
# + $ghi }}]
} -result loadStk
test compExpr-8.3 {TIP 582: expression comments} -setup {} -body {
extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
$abc
# + $def\
+ $ghi
}}]
} -result loadStk
test compExpr-8.4 {TIP 582: expression comments} -setup {} -body {
extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
$abc
# + $def\\
+ $ghi
}}]
} -result {loadStk loadStk add}
# cleanup
catch {unset a}
|
| ︙ | ︙ |
Changes to tests/compile.test.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup {
catch {namespace delete test_ns_compile}
catch {unset x}
} -body {
set x 123
namespace eval test_ns_compile {
| | | | | | | | | | | | | | | | | 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 |
test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup {
catch {namespace delete test_ns_compile}
catch {unset x}
} -body {
set x 123
namespace eval test_ns_compile {
proc set {args} {
global x
lappend x test_ns_compile::set
}
proc p {} {
set 0
}
}
list [test_ns_compile::p] [set x]
} -result {{123 test_ns_compile::set} {123 test_ns_compile::set}}
test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
} {1 {wrong # args: should be "p x"}}
test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} -setup {
catch {unset x}
} -body {
set x 123
list $::x [expr {"x" in [info globals]}]
} -result {123 1}
test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup {
catch {unset y}
} -body {
proc p {} {
set ::y 789
return $::y
}
list [p] $::y [expr {"y" in [info globals]}]
} -result {789 789 1}
test compile-2.3 {TclCompileDollarVar: global array name with ::s} -setup {
catch {unset a}
} -body {
set ::a(1) 2
list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {"a" in [info globals]}]
} -result {2 3 3 1}
test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup {
catch {unset a}
} -body {
proc p {} {
set ::a(1) 1
return $::a($::a(1))
}
list [p] $::a(1) [expr {"a" in [info globals]}]
} -result {1 1 1}
test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -setup {
catch {unset a}
} -body {
proc p {} {
global a
set a(1) 1
return ${a(1)}$::a(1)$a(1)
}
list [p] $::a(1) [expr {"a" in [info globals]}]
} -result {111 1 1}
test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} -setup {
catch {unset a}
} -body {
set a(1) xyzzyx
proc p {} {
global a
catch {set x 123} a(1)
}
list [p] $a(1)
} -result {0 123}
test compile-3.2 {TclCompileCatchCmd: non-local variables} {
set ::foo 1
proc catch-test {} {
catch {set x 3} ::foo
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup {
catch {unset x}
catch {unset y}
} -body {
set x 123
proc p {} {
| | | | | | | | | | 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 |
test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup {
catch {unset x}
catch {unset y}
} -body {
set x 123
proc p {} {
set ::y 789
return $::y
}
list $::x [expr {"x" in [info globals]}] \
[p] $::y [expr {"y" in [info globals]}]
} -result {123 1 789 789 1}
test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup {
catch {unset a}
} -body {
set ::a(1) 2
proc p {} {
set ::a(1) 1
return $::a($::a(1))
}
list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {"a" in [info globals]}]
} -result {2 1 3 3 1}
test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} -setup {
catch {namespace delete test_ns_compile}
catch {unset x}
} -body {
namespace eval test_ns_compile {
variable v hello
variable arr
set ::x $::test_ns_compile::v
set ::test_ns_compile::arr(1) 123
}
list $::x $::test_ns_compile::arr(1)
} -result {hello 123}
test compile-7.1 {TclCompileWhileCmd: command substituted test expression} {
set i 0
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
} {0 4}
test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} {
set x ]
} {]}
test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
proc p {} {
| | | | | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 |
} {0 4}
test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} {
set x ]
} {]}
test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
proc p {} {
set x {}
eval $x
append x { }
eval $x
}
p
} {}
test compile-10.1 {BLACKBOX: exception stack overflow} {
set x {{0}}
set y 0
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 495 496 497 498 499 500 |
append code "\}$e"
}
#puts [format "%% %.40s ... %d bytes" $code [string length $code]]
return $code
}}
}
test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup {
_ti_gencode
interp recursionlimit ti [expr {10000+50}]
ti eval {set result {}}
} -body {
# Test different compilation variants (instructions evalStk, invokeStk, etc),
# with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
| > > > > > > > > | | 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 |
append code "\}$e"
}
#puts [format "%% %.40s ... %d bytes" $code [string length $code]]
return $code
}}
}
test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup {
# dynamic constraint - ensure the stack is large enough on this box for this test:
if {
[testConstraint unix] &&
![catch { exec sh -c {ulimit -s} } stsz] &&
$stsz ne "unlimited" && $stsz <= 2048
} {
tcltest::Skip "too small stack limit ($stsz <= 2048)"
}
_ti_gencode
interp recursionlimit ti [expr {10000+50}]
ti eval {set result {}}
} -body {
# Test different compilation variants (instructions evalStk, invokeStk, etc),
# with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
# boxes or systems, please don't decrease it (either provide new or extend a constraint above)
ti eval {foreach cmd {eval "if 1" try catch} {
set c [gencode [expr {[tcl::build-info debug] ? 1500 : 1000}] $cmd]
if 1 $c
}}
ti eval {set result}
} -result {1 1 1 1}
test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup {
|
| ︙ | ︙ | |||
823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
tcl::unsupported::disassemble objmethod foo bar
} -cleanup {
foo destroy
} -match glob -result *
# There never was a compile-18.20.
# The keys of the dictionary produced by [getbytecode] are defined.
set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth}
test compile-18.21 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode
} -match glob -result {wrong # args: should be "*"}
test compile-18.22 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode ?
} -result "bad type \"?\": must be $disassemblables"
test compile-18.23 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode lambda
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
test compile-18.24 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode lambda \{
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.25 {disassembler - basics} -body {
dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
| > | | | | 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 |
tcl::unsupported::disassemble objmethod foo bar
} -cleanup {
foo destroy
} -match glob -result *
# There never was a compile-18.20.
# The keys of the dictionary produced by [getbytecode] are defined.
set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth}
set allbytecodekeys [list {*}$bytecodekeys initiallinenumber sourcefile]
test compile-18.21 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode
} -match glob -result {wrong # args: should be "*"}
test compile-18.22 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode ?
} -result "bad type \"?\": must be $disassemblables"
test compile-18.23 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode lambda
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
test compile-18.24 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode lambda \{
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.25 {disassembler - basics} -body {
dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
} -result $allbytecodekeys
test compile-18.26 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode proc
} -match glob -result {wrong # args: should be "* proc procName"}
test compile-18.27 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode proc nosuchproc
} -result {"nosuchproc" isn't a procedure}
test compile-18.28 {disassembler - basics} -setup {
proc chewonthis {} {}
} -body {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename chewonthis {}
} -result $allbytecodekeys
test compile-18.28.1 {disassembler - tricky bit} -setup {
eval [list proc chewonthis {} {}]
} -body {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename chewonthis {}
} -result $bytecodekeys
test compile-18.28.2 {disassembler - tricky bit} -setup {
eval {proc chewonthis {} {}}
} -body {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename chewonthis {}
} -result $allbytecodekeys
test compile-18.28.3 {disassembler - tricky bit} -setup {
proc Proc {n a b} {
proc $n $a $b
}
Proc chewonthis {} {}
} -body {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
}
Proc chewonthis {} {}
} -body {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename Proc {}
rename chewonthis {}
| | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
}
Proc chewonthis {} {}
} -body {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename Proc {}
rename chewonthis {}
} -result $allbytecodekeys
test compile-18.29 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode script
} -match glob -result {wrong # args: should be "* script script"}
test compile-18.30 {disassembler - basics} -body {
dict keys [tcl::unsupported::getbytecode script {}]
} -result $bytecodekeys
test compile-18.31 {disassembler - basics} -returnCodes error -body {
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 |
} -result {unknown method "nosuchmethod"}
test compile-18.35 {disassembler - basics} -setup {
oo::class create foo {method bar {} {}}
} -body {
dict keys [tcl::unsupported::getbytecode method foo bar]
} -cleanup {
foo destroy
| | | | 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 |
} -result {unknown method "nosuchmethod"}
test compile-18.35 {disassembler - basics} -setup {
oo::class create foo {method bar {} {}}
} -body {
dict keys [tcl::unsupported::getbytecode method foo bar]
} -cleanup {
foo destroy
} -result $allbytecodekeys
test compile-18.36 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode objmethod
} -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
test compile-18.37 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode objmethod nosuchobject foo
} -result {nosuchobject does not refer to an object}
test compile-18.38 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode objmethod oo::object nosuchmethod
} -result {unknown method "nosuchmethod"}
test compile-18.39 {disassembler - basics} -setup {
oo::object create foo
oo::objdefine foo {method bar {} {}}
} -body {
dict keys [tcl::unsupported::getbytecode objmethod foo bar]
} -cleanup {
foo destroy
} -result $allbytecodekeys
test compile-18.40 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble constructor
} -match glob -result {wrong # args: should be "* constructor className"}
test compile-18.41 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble constructor nosuchclass
} -result {nosuchclass does not refer to an object}
test compile-18.42 {disassembler - basics} -returnCodes error -setup {
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
} -result {"constructorless" has no defined constructor}
test compile-18.48 {disassembler - basics} -setup {
oo::class create foo {constructor {} {set x 1}}
} -body {
dict keys [tcl::unsupported::getbytecode constructor foo]
} -cleanup {
foo destroy
| | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 |
} -result {"constructorless" has no defined constructor}
test compile-18.48 {disassembler - basics} -setup {
oo::class create foo {constructor {} {set x 1}}
} -body {
dict keys [tcl::unsupported::getbytecode constructor foo]
} -cleanup {
foo destroy
} -result $allbytecodekeys
# There is no compile-18.49
test compile-18.50 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble destructor
} -match glob -result {wrong # args: should be "* destructor className"}
test compile-18.51 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble destructor nosuchclass
} -result {nosuchclass does not refer to an object}
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 |
} -result {"constructorless" has no defined destructor}
test compile-18.58 {disassembler - basics} -setup {
oo::class create foo {destructor {set x 1}}
} -body {
dict keys [tcl::unsupported::getbytecode destructor foo]
} -cleanup {
foo destroy
| | | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 |
} -result {"constructorless" has no defined destructor}
test compile-18.58 {disassembler - basics} -setup {
oo::class create foo {destructor {set x 1}}
} -body {
dict keys [tcl::unsupported::getbytecode destructor foo]
} -cleanup {
foo destroy
} -result $allbytecodekeys
test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
# This will panic in a --enable-symbols=compile build, unless bug is fixed.
apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *
test compile-20.1 {ensure there are no infinite loops in optimizing} {
|
| ︙ | ︙ |
Changes to tests/coroutine.test.
| ︙ | ︙ | |||
821 822 823 824 825 826 827 |
# c1. After the fix, that doesn't happen, so if c1 still exists call it
# one final time to allow it to finish and clean up
rename c1 {}
}
return [list $done0 $done1]
} -result {failure failure}
| < < < < < < < < < < < < < < < < | | | > | 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
# c1. After the fix, that doesn't happen, so if c1 still exists call it
# one final time to allow it to finish and clean up
rename c1 {}
}
return [list $done0 $done1]
} -result {failure failure}
test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
interp create child
child eval {
coroutine demo apply {{} { while {1} yield }}
demo
coroinject demo set ::result inject-executed
}
interp delete child
} -result {}
test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
interp create child
child eval {
coroutine demo apply {{} { while {1} yield }}
demo
coroinject demo lappend ::result inject-executed
}
child eval demo
set result [child eval {set ::result}]
interp delete child
set result
} -result {inject-executed yield {}}
test coroutine-9.1 {coroprobe with yield} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
} -cleanup {
catch {rename demo {}}
} -result {1 {} 2 {}}
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 |
test coroutine-12.1 {coroutine general introspection} -setup {
set i [interp create]
} -body {
$i eval {
# Make the introspection code
namespace path tcl::unsupported
| | | | 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 |
test coroutine-12.1 {coroutine general introspection} -setup {
set i [interp create]
} -body {
$i eval {
# Make the introspection code
namespace path tcl::unsupported
proc probe {var type args} {
upvar 1 $var v
set f [info frame]
incr f -1
set result [list $v [dict get [info frame $f] proc]]
if {$type eq "yield"} {
tailcall yield $result
} else {
tailcall yieldto string cat $result
}
}
proc pokecoro {c var} {
coroinject $c probe $var
$c
}
# Coroutine implementations
proc cbody1 {} {
set val [info coroutine]
set accum {}
|
| ︙ | ︙ |
Changes to tests/dict.test.
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
}}
} -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}
| < < < < < | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
}}
} -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-4.1 {dict replace command} {
dict replace {a b c d}
} {a b c d}
test dict-4.2 {dict replace command} {
dict replace {a b c d} e f
} {a b c d e f}
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
} -result {{foo bar bar foo} 6}
test dict-17.12 {dict filter command: script} -returnCodes error -body {
dict filter {a b} script {k v} {
concat $k $v
}
} -cleanup {
unset k v
| | | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
} -result {{foo bar bar foo} 6}
test dict-17.12 {dict filter command: script} -returnCodes error -body {
dict filter {a b} script {k v} {
concat $k $v
}
} -cleanup {
unset k v
} -result {expected boolean value but got a list}
test dict-17.13 {dict filter command: script} -body {
list [catch {dict filter {a b} script {k v} {error x}} msg] $msg \
$::errorInfo
} -cleanup {
unset k v msg
} -result {1 x {x
while executing
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
unset ld
} -result {8 3 8}
# This is a test for a specific bug.
# It shows a bad ref counter when running with memdebug on.
test dict-19.1 {memory bug} {
apply {{} {
| | | | | 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 |
unset ld
} -result {8 3 8}
# This is a test for a specific bug.
# It shows a bad ref counter when running with memdebug on.
test dict-19.1 {memory bug} {
apply {{} {
set successors [dict create x {c d}]
dict set successors x a b
dict get $successors x
}}
} [dict create c d a b]
test dict-19.2 {dict: testing for leaks} -constraints memory -body {
# This test is made to stress object reference management
memtest {
apply {{} {
# A shared invalid dictionary
|
| ︙ | ︙ |
Changes to tests/encoding.test.
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
append a $a
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
| | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
append a $a
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary
puts -nonewline $f "ab\x8C\xC1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation lf -encoding shiftjis
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
} ab乎g
test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
append a $a
set x [encoding convertto jis0208 $a]
list [string length $x] [string range $x 0 1]
} "1024 8C"
test encoding-10.1 {Tcl_UtfToExternal} {
set f [open [file join [temporaryDirectory] dummy] w]
| | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
append a $a
set x [encoding convertto jis0208 $a]
list [string length $x] [string range $x 0 1]
} "1024 8C"
test encoding-10.1 {Tcl_UtfToExternal} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation lf -encoding shiftjis
puts -nonewline $f ab乎g
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
} "ab\x8C\xC1g"
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
} \x00
test encoding-15.30 {UtfToUtfProc -profile strict CESU-8} {
encoding convertto -profile strict cesu-8 \x00
} \x00
test encoding-15.31 {UtfToUtfProc -profile strict CESU-8 (bytes F0-F4 are invalid)} -body {
encoding convertfrom -profile strict cesu-8 \xF1\x86\x83\x9C
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF1'}
test encoding-16.1 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 NN]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.2 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"]
| > > > > > > | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
} \x00
test encoding-15.30 {UtfToUtfProc -profile strict CESU-8} {
encoding convertto -profile strict cesu-8 \x00
} \x00
test encoding-15.31 {UtfToUtfProc -profile strict CESU-8 (bytes F0-F4 are invalid)} -body {
encoding convertfrom -profile strict cesu-8 \xF1\x86\x83\x9C
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF1'}
test encoding-15.32 {UtfToUtfProc CESU-8 [2f22a7364d]} -body {
encoding convertto cesu-8 \U1f600
} -result \xED\xA0\xBD\xED\xB8\x80
test encoding-15.33 {UtfToUtfProc CESU-8 [63325009a8]} -body {
encoding convertto cesu-8 \u0400
} -result \xD0\x80
test encoding-16.1 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 NN]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.2 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"]
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 | 小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部( casino_japanese@___.com )までご住所変更済の連絡をいただけないで しょうか?" cd [temporaryDirectory] set fid [open iso2022.txt w] | | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお
お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部(
casino_japanese@___.com )までご住所変更済の連絡をいただけないで
しょうか?"
cd [temporaryDirectory]
set fid [open iso2022.txt w]
fconfigure $fid -translation binary
puts -nonewline $fid $iso2022encData
close $fid
test encoding-23.1 {iso2022-jp escape encoding test} {
string equal $iso2022uniData $iso2022uniData2
} 1
test encoding-23.2 {iso2022-jp escape encoding test} {
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
return $diff
}
# Create char tables.
cd [temporaryDirectory]
foreach enc {cp932 euc-jp iso2022-jp} {
set f [open $enc.chars w]
| | | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 |
return $diff
}
# Create char tables.
cd [temporaryDirectory]
foreach enc {cp932 euc-jp iso2022-jp} {
set f [open $enc.chars w]
fconfigure $f -encoding iso8859-1
foreach-jisx0208 code {
puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]]
}
close $f
}
# shiftjis == cp932 for jisx0208.
file copy -force cp932.chars shiftjis.chars
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 | encoding convertto -profile tcl8 $name $string # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. llength $name } return $count | | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 |
encoding convertto -profile tcl8 $name $string
# discard the cached internal representation of Tcl_Encoding
# Unfortunately, without this, encoding 2-1 fails.
llength $name
}
return $count
} -result 93
runtests
test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xFF
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 |
}
test encoding-29.0 {get encoding nul terminator lengths} -constraints {
testencoding
} -body {
list \
| | | | | | | 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
}
test encoding-29.0 {get encoding nul terminator lengths} -constraints {
testencoding
} -body {
list \
[testencoding nullength ascii] \
[testencoding nullength utf-16] \
[testencoding nullength utf-32] \
[testencoding nullength gb12345] \
[testencoding nullength ksc5601]
} -result {1 2 4 2 2}
test encoding-30.0 {encoding convertto large strings UINT_MAX} -constraints {
perf
} -body {
# Test to ensure not misinterpreted as -1
list [string length [set s [string repeat A 0xFFFFFFFF]]] [string equal $s [encoding convertto ascii $s]]
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 |
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:
| > > > > > > > > > > | 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 |
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-201c7a3aa6-strict {Crash encoding non-BMP to iso2022} -body {
encoding convertto -profile strict iso2022 \U1f600
} -result {unexpected character at index 0: 'U+01F600'} -returnCodes error
test encoding-bug-201c7a3aa6-replace {Crash encoding non-BMP to iso2022} -body {
encoding convertto -profile replace iso2022 \U1f600
} -result ?
test encoding-bug-201c7a3aa6-tcl8 {Crash encoding non-BMP to iso2022} -body {
encoding convertto -profile tcl8 iso2022 \U1f600
} -result ?
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/env.test.
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
proc manglechar c {
return [format {\u%04x} [scan $c %c]]
}
set names [lsort [array names env]]
if {$tcl_platform(platform) eq "windows"} {
lrem names HOME
| | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
proc manglechar c {
return [format {\u%04x} [scan $c %c]]
}
set names [lsort [array names env]]
if {$tcl_platform(platform) eq "windows"} {
lrem names HOME
lrem names COMSPEC
lrem names ComSpec
lrem names ""
}
foreach name @keep@ {
lrem names $name
}
foreach p $names {
|
| ︙ | ︙ | |||
403 404 405 406 407 408 409 |
test env-7.3 {
[9b4702]: testing existence of env(some_thing) should not destroy trace
} -setup setup1 -body {
apply {{} {
catch {unset ::env(test7_3)}
proc foo args {
| | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
test env-7.3 {
[9b4702]: testing existence of env(some_thing) should not destroy trace
} -setup setup1 -body {
apply {{} {
catch {unset ::env(test7_3)}
proc foo args {
set ::env(test7_3) ok
}
trace add variable ::env(not_yet_existent) write foo
info exists ::env(not_yet_existent)
set ::env(not_yet_existent) "Now I'm here";
return [info exists ::env(test7_3)]
}}
} -cleanup cleanup1 -result 1
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
}
} -result {}
test env-10.0 {
Unequal environment strings test should test unequal
} -constraints {unix haveBash utf8system knownBug} -setup {
set tclScript [makeFile {
| | | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
}
} -result {}
test env-10.0 {
Unequal environment strings test should test unequal
} -constraints {unix haveBash utf8system knownBug} -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]
} -body {
exec {*}[auto_execok bash] $shScript
} -result 0
|
| ︙ | ︙ |
Changes to tests/error.test.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
# This test is non-portable: it generates a memory fault on machines like
# DEC Alphas (infinite recursion overflows stack?)
#
# That claims sounds like a bug to be fixed rather than a portability
# problem. Anyhow, I believe it's out of date (bug's been fixed) so this
# test is re-enabled.
proc p {} {
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
# This test is non-portable: it generates a memory fault on machines like
# DEC Alphas (infinite recursion overflows stack?)
#
# That claims sounds like a bug to be fixed rather than a portability
# problem. Anyhow, I believe it's out of date (bug's been fixed) so this
# test is re-enabled.
proc p {} {
uplevel 1 catch p error
}
p
} 0
# Check errors nested in procedures. Also check the optional argument to
# "error" to generate a new error trace.
|
| ︙ | ︙ |
Changes to tests/event.test.
| ︙ | ︙ | |||
502 503 504 505 506 507 508 |
} {even 16
}
test event-10.1 {Tcl_Exit procedure} {stdio} {
set child [open |[list [interpreter]] r+]
puts $child "exit 3"
list [catch {close $child} msg] $msg [lindex $::errorCode 0] \
| | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
} {even 16
}
test event-10.1 {Tcl_Exit procedure} {stdio} {
set child [open |[list [interpreter]] r+]
puts $child "exit 3"
list [catch {close $child} msg] $msg [lindex $::errorCode 0] \
[lindex $::errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}
test event-11.1 {Tcl_VwaitCmd procedure} -body {
vwait
} -result {}
test event-11.3 {Tcl_VwaitCmd procedure} -setup {
catch {unset x}
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
}
} {}
test event-11.8 {Bug 16828b3744} -setup {
oo::class create A {
variable continue
method start {} {
| | | | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 |
}
} {}
test event-11.8 {Bug 16828b3744} -setup {
oo::class create A {
variable continue
method start {} {
after idle [self] destroy
set continue 0
vwait [namespace current]::continue
}
destructor {
set continue 1
}
}
} -body {
[A new] start
} -cleanup {
A destroy
} -result {}
|
| ︙ | ︙ |
Changes to tests/exec.test.
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
Third line}
test exec-17.1 {inheriting standard I/O} -constraints {exec} -setup {
set path(script) [makeFile {} script]
set f [open $path(script) w]
puts $f [list lassign [list \
[info nameofexecutable] $path(gorp.file) $path(echo) $path(sleep) \
| | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
Third line}
test exec-17.1 {inheriting standard I/O} -constraints {exec} -setup {
set path(script) [makeFile {} script]
set f [open $path(script) w]
puts $f [list lassign [list \
[info nameofexecutable] $path(gorp.file) $path(echo) $path(sleep) \
] exe file echo sleep]
puts $f {
close stdout
set f [open $file w]
catch {exec $exe $echo foobar &}
exec $exe $sleep 2
close $f
}
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
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 {
| | | | | | 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 |
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 {
|
| ︙ | ︙ |
Changes to tests/execute.test.
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x + 1}
} 2.0
test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x + 1}} msg] $msg
| | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x + 1}
} 2.0
test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x + 1}} msg] $msg
} {1 {cannot use non-numeric string "foo" as left operand of "+"}}
test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 + $x}
} 2
test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {1 + $x}
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 + $x}
} 2.0
test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 + $x}} msg] $msg
| | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 + $x}
} 2.0
test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 + $x}} msg] $msg
} {1 {cannot use non-numeric string "foo" as right operand of "+"}}
# INST_SUB is partially tested:
test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} {
set x [testintobj set 0 1]
expr {$x - 1}
} 0
test execute-3.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} {
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x - 1}
} 0.0
test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x - 1}} msg] $msg
| | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x - 1}
} 0.0
test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x - 1}} msg] $msg
} {1 {cannot use non-numeric string "foo" as left operand of "-"}}
test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 - $x}
} 0
test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {1 - $x}
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 - $x}
} 0.0
test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 - $x}} msg] $msg
| | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 - $x}
} 0.0
test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 - $x}} msg] $msg
} {1 {cannot use non-numeric string "foo" as right operand of "-"}}
# INST_MULT is partially tested:
test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} {
set x [testintobj set 1 1]
expr {$x * 1}
} 1
test execute-3.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} {
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x * 1}
} 1.0
test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x * 1}} msg] $msg
| | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x * 1}
} 1.0
test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x * 1}} msg] $msg
} {1 {cannot use non-numeric string "foo" as left operand of "*"}}
test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {1 * $x}
} 1
test execute-3.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} {
set x [testdoubleobj set 1 2.0]
expr {1 * $x}
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {1 * $x}
} 1.0
test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 * $x}} msg] $msg
| | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {1 * $x}
} 1.0
test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 * $x}} msg] $msg
} {1 {cannot use non-numeric string "foo" as right operand of "*"}}
# INST_DIV is partially tested:
test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} {
set x [testintobj set 1 1]
expr {$x / 1}
} 1
test execute-3.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} {
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x / 1}
} 1.0
test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x / 1}} msg] $msg
| | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x / 1}
} 1.0
test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x / 1}} msg] $msg
} {1 {cannot use non-numeric string "foo" as left operand of "/"}}
test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {2 / $x}
} 2
test execute-3.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} {
set x [testdoubleobj set 1 1.0]
expr {2 / $x}
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {2 / $x}
} 2.0
test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 / $x}} msg] $msg
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {2 / $x}
} 2.0
test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 / $x}} msg] $msg
} {1 {cannot use non-numeric string "foo" as right operand of "/"}}
# INST_UPLUS is partially tested:
test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} {
set x [testintobj set 1 1]
expr {+ $x}
} 1
test execute-3.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} {
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {+ $x}
} 1.0
test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {+ $x}} msg] $msg
| | | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {+ $x}
} 1.0
test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {+ $x}} msg] $msg
} {1 {cannot use non-numeric string "foo" as operand of "+"}}
# INST_UMINUS is partially tested:
test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} {
set x [testintobj set 1 1]
expr {- $x}
} -1
test execute-3.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} {
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {- $x}
} -1.0
test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {- $x}} msg] $msg
| | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {- $x}
} -1.0
test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {- $x}} msg] $msg
} {1 {cannot use non-numeric string "foo" as operand of "-"}}
# INST_LNOT is partially tested:
test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
set x [testintobj set 1 2]
expr {! $x}
} 0
test execute-3.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
|
| ︙ | ︙ | |||
457 458 459 460 461 462 463 |
test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
set x [teststringobj set 1 0.0]
expr {! $x}
} 1
test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {! $x}} msg] $msg
| | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
set x [teststringobj set 1 0.0]
expr {! $x}
} 1
test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {! $x}} msg] $msg
} {1 {cannot use non-numeric string "foo" as operand of "!"}}
# INST_TRY_CVT_TO_NUMERIC is partially tested:
test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} {
set x [testintobj set 1 1]
expr {$x}
} 1
test execute-3.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} {
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
unset -nocomplain x
unset -nocomplain y
} -body {
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
unset -nocomplain x
unset -nocomplain y
} -body {
namespace eval test_ns_1 {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_1::test_ns_2 {
namespace import ::test_ns_1::*
}
set x "test_ns_1::"
set y "test_ns_2::"
list [namespace which -command ${x}${y}cmd1] \
[catch {namespace which -command ${x}${y}cmd2} msg] $msg \
[catch {namespace which -command ${x}${y}:cmd2} msg] $msg
} -result {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}}
test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
unset -nocomplain l
} -body {
proc foo {} {
return "global foo"
}
namespace eval test_ns_1 {
proc whichFoo {} {
return [namespace which -command foo]
}
}
set l ""
lappend l [test_ns_1::whichFoo]
namespace eval test_ns_1 {
proc foo {} {
return "namespace foo"
}
}
lappend l [test_ns_1::whichFoo]
} -result {::foo ::test_ns_1::foo}
test execute-4.3 {Tcl_GetCommandFromObj, command never found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
} -body {
namespace eval test_ns_1 {
proc foo {} {
return "namespace foo"
}
}
namespace eval test_ns_1 {
proc foo {} {
return "namespace foo"
}
}
list [namespace eval test_ns_1 {namespace which -command foo}] \
[rename test_ns_1::foo ""] \
[catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg
} -result {::test_ns_1::foo {} 0 {}}
test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
unset -nocomplain l
} -body {
proc {} {} {return {}}
{}
set l {}
lindex {} 0
{}
} -result {}
test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} {
proc {} {} {}
proc { } {} {}
proc p {} {
set x {}
$x
append x { }
$x
}
p
} {}
test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} {
set w {3*5}
proc a {obj} {expr $obj}
set res "[a $w]:[a $w]"
|
| ︙ | ︙ |
Changes to tests/expr-old.test.
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
test expr-old-1.53 {integer operators} {
unset -nocomplain x
set x yes
list [expr {1 && $x}] [expr {$x && 1}] \
| | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
test expr-old-1.53 {integer operators} {
unset -nocomplain x
set x yes
list [expr {1 && $x}] [expr {$x && 1}] \
[expr {0 || $x}] [expr {$x || 0}]
} {1 1 1 1}
# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.
test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2
test expr-old-2.2 {floating-point operators} {expr -(1.125+4.25)} -5.375
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 |
list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
test expr-old-3.1 {illegal floating-point operations} {
list [catch {expr ~4.0} msg] $msg
| | | | | | | | | | | | 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 |
list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
test expr-old-3.1 {illegal floating-point operations} {
list [catch {expr ~4.0} msg] $msg
} {1 {cannot use floating-point value "4.0" as operand of "~"}}
test expr-old-3.2 {illegal floating-point operations} {
list [catch {expr 27%4.0} msg] $msg
} {1 {cannot use floating-point value "4.0" as right operand of "%"}}
test expr-old-3.3 {illegal floating-point operations} {
list [catch {expr 27.0%4} msg] $msg
} {1 {cannot use floating-point value "27.0" as left operand of "%"}}
test expr-old-3.4 {illegal floating-point operations} {
list [catch {expr 1.0<<3} msg] $msg
} {1 {cannot use floating-point value "1.0" as left operand of "<<"}}
test expr-old-3.5 {illegal floating-point operations} {
list [catch {expr 3<<1.0} msg] $msg
} {1 {cannot use floating-point value "1.0" as right operand of "<<"}}
test expr-old-3.6 {illegal floating-point operations} {
list [catch {expr 24.0>>3} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of ">>"}}
test expr-old-3.7 {illegal floating-point operations} {
list [catch {expr 24>>3.0} msg] $msg
} {1 {cannot use floating-point value "3.0" as right operand of ">>"}}
test expr-old-3.8 {illegal floating-point operations} {
list [catch {expr 24&3.0} msg] $msg
} {1 {cannot use floating-point value "3.0" as right operand of "&"}}
test expr-old-3.9 {illegal floating-point operations} {
list [catch {expr 24.0|3} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of "|"}}
test expr-old-3.10 {illegal floating-point operations} {
list [catch {expr 24.0^3} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of "^"}}
# Check the string operators individually.
test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0
test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0
test expr-old-4.3 {string operators} {expr {"g" > "def"}} 1
test expr-old-4.4 {string operators} {expr {"abc" < "abd"}} 1
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar
# Operators that aren't legal on string operands.
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg] $msg
| | | | | | | | | | | | | | | | 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 |
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar
# Operators that aren't legal on string operands.
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg] $msg
} {1 {cannot use non-numeric string "a" as operand of "-"}}
test expr-old-5.2 {illegal string operations} {
list [catch {expr {+"a"}} msg] $msg
} {1 {cannot use non-numeric string "a" as operand of "+"}}
test expr-old-5.3 {illegal string operations} {
list [catch {expr {~"a"}} msg] $msg
} {1 {cannot use non-numeric string "a" as operand of "~"}}
test expr-old-5.4 {illegal string operations} {
list [catch {expr {!"a"}} msg] $msg
} {1 {cannot use non-numeric string "a" as operand of "!"}}
test expr-old-5.5 {illegal string operations} {
list [catch {expr {"a"*"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "*"}}
test expr-old-5.6 {illegal string operations} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "/"}}
test expr-old-5.7 {illegal string operations} {
list [catch {expr {"a"%"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "%"}}
test expr-old-5.8 {illegal string operations} {
list [catch {expr {"a"+"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "+"}}
test expr-old-5.9 {illegal string operations} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "-"}}
test expr-old-5.10 {illegal string operations} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "<<"}}
test expr-old-5.11 {illegal string operations} {
list [catch {expr {"a">>"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of ">>"}}
test expr-old-5.12 {illegal string operations} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "&"}}
test expr-old-5.13 {illegal string operations} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "^"}}
test expr-old-5.14 {illegal string operations} {
list [catch {expr {"a"|"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "|"}}
test expr-old-5.15 {illegal string operations} {
list [catch {expr {"a"&&"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-old-5.16 {illegal string operations} {
list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-old-5.17 {illegal string operations} {
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 |
test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
test expr-old-26.1 {error conditions} {
list [catch {expr 2+"a"} msg] $msg
| | | | | 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 |
test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
test expr-old-26.1 {error conditions} {
list [catch {expr 2+"a"} msg] $msg
} {1 {cannot use non-numeric string "a" as right operand of "+"}}
test expr-old-26.2 {error conditions} -body {
expr 2+4*
} -returnCodes error -match glob -result *
test expr-old-26.3 {error conditions} -body {
expr 2+4*(
} -returnCodes error -match glob -result *
unset -nocomplain _non_existent_
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg] $msg
} {1 {can't read "_non_existent_": no such variable}}
set a xx
test expr-old-26.5 {error conditions} {
list [catch {expr {2+$a}} msg] $msg
} {1 {cannot use non-numeric string "xx" as right operand of "+"}}
test expr-old-26.6 {error conditions} {
list [catch {expr {2+[set a]}} msg] $msg
} {1 {cannot use non-numeric string "xx" as right operand of "+"}}
test expr-old-26.7 {error conditions} -body {
expr {2+(4}
} -returnCodes error -match glob -result *
test expr-old-26.8 {error conditions} {
list [catch {expr 2/0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.9 {error conditions} {
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 |
expr 2`
} -returnCodes error -match glob -result *
test expr-old-26.12 {error conditions} -body {
expr a.b
} -returnCodes error -match glob -result *
test expr-old-26.13 {error conditions} {
list [catch {expr {"a"/"b"}} msg] $msg
| | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
expr 2`
} -returnCodes error -match glob -result *
test expr-old-26.12 {error conditions} -body {
expr a.b
} -returnCodes error -match glob -result *
test expr-old-26.13 {error conditions} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "/"}}
test expr-old-26.14 {error conditions} -body {
expr 2:3
} -returnCodes error -match glob -result *
test expr-old-26.15 {error conditions} -body {
expr a@b
} -returnCodes error -match glob -result *
test expr-old-26.16 {error conditions} {
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 |
list [catch {expr func_2(1.0)} msg] $msg
} -match glob -result {1 {* "*func_2"}}
test expr-old-34.2 {errors in math functions} -body {
expr func|(1.0)
} -returnCodes error -match glob -result *
test expr-old-34.3 {errors in math functions} {
list [catch {expr {hypot("a b", 2.0)}} msg] $msg
| | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
list [catch {expr func_2(1.0)} msg] $msg
} -match glob -result {1 {* "*func_2"}}
test expr-old-34.2 {errors in math functions} -body {
expr func|(1.0)
} -returnCodes error -match glob -result *
test expr-old-34.3 {errors in math functions} {
list [catch {expr {hypot("a b", 2.0)}} msg] $msg
} {1 {expected floating-point number but got a list}}
test expr-old-34.4 {errors in math functions} -body {
expr hypot(1.0 2.0)
} -returnCodes error -match glob -result *
test expr-old-34.5 {errors in math functions} -body {
expr hypot(1.0, 2.0
} -returnCodes error -match glob -result *
test expr-old-34.6 {errors in math functions} -body {
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 |
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0o289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0o289
list [catch {expr {$x+1}} msg] $msg
| | | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 |
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0o289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0o289
list [catch {expr {$x+1}} msg] $msg
} {1 {cannot use non-numeric string "0o289" as left operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
list [catch {expr 0289.1} msg] $msg
} {0 289.1}
test expr-old-36.4 {ExprLooksLikeInt procedure} {
set x 0289.1
list [catch {expr {$x+1}} msg] $msg
} {0 290.1}
|
| ︙ | ︙ | |||
985 986 987 988 989 990 991 |
expr {$x+1}
} 665802003400000000000001
# tests for [Bug #587140]
test expr-old-36.12 {ExprLooksLikeInt procedure} {
set x "10;"
list [catch {expr {$x+1}} msg] $msg
| | | | | 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 |
expr {$x+1}
} 665802003400000000000001
# tests for [Bug #587140]
test expr-old-36.12 {ExprLooksLikeInt procedure} {
set x "10;"
list [catch {expr {$x+1}} msg] $msg
} {1 {cannot use non-numeric string "10;" as left operand of "+"}}
test expr-old-36.13 {ExprLooksLikeInt procedure} {
set x " +"
list [catch {expr {$x+1}} msg] $msg
} {1 {cannot use non-numeric string " +" as left operand of "+"}}
test expr-old-36.14 {ExprLooksLikeInt procedure} {
set x "123456789012345678901234567890 "
expr {$x+1}
} 123456789012345678901234567891
test expr-old-36.15 {ExprLooksLikeInt procedure} {
set x "0o99 "
list [catch {expr {$x+1}} msg] $msg
} {1 {cannot use non-numeric string "0o99 " as left operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
set x " 0xffffffffffffffffffffffffffffffffffffff "
expr {$x+1}
} [expr 0x100000000000000000000000000000000000000]
test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong {
testexprlong 4+1
|
| ︙ | ︙ |
Changes to tests/expr.test.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
return $c
}
proc hello_world {} {
global a
set a ""
set L1 [set l0 [set h_1 [set q 0]]]
for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0]
| | | | | | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
return $c
}
proc hello_world {} {
global a
set a ""
set L1 [set l0 [set h_1 [set q 0]]]
for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0]
:!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])]
?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3?
[incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]]
:[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2
?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]}
expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]}
}
set a
}
proc 12days {a b c} {
global xxx
expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \
|
| ︙ | ︙ | |||
246 247 248 249 250 251 252 |
test expr-4.9 {CompileLorExpr: long lor arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test expr-4.10 {CompileLorExpr: error compiling ! operand} {
list [catch {expr {!"a"}} msg] $msg
| | | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
test expr-4.9 {CompileLorExpr: long lor arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test expr-4.10 {CompileLorExpr: error compiling ! operand} {
list [catch {expr {!"a"}} msg] $msg
} {1 {cannot use non-numeric string "a" as operand of "!"}}
test expr-4.11 {CompileLorExpr: error compiling land arms} {
list [catch {expr {"a"||0}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-4.12 {CompileLorExpr: error compiling land arms} {
list [catch {expr {0||"a"}} msg] $msg
} {1 {expected boolean value but got "a"}}
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
expr 2***3|6
} -returnCodes error -match glob -result *
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
| | | | | | 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 |
expr 2***3|6
} -returnCodes error -match glob -result *
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of "^"}}
test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "^"}}
test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test expr-7.5 {CompileBitAndExpr: error in equality expr} -body {
expr x==3
} -returnCodes error -match glob -result *
test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2***3&6
} -returnCodes error -match glob -result *
test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2&x
} -returnCodes error -match glob -result *
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of "&"}}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "&"}}
test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-7.20 {CompileBitAndExpr: error in equality expr} -body {
expr xne3
} -returnCodes error -match glob -result *
test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test expr-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
| | | | | > > > > > > > > > | | | | | 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 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test expr-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
} {1 {cannot use floating-point value "24.0" as left operand of ">>"}}
test expr-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "<<"}}
test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6
test expr-11.5 {CompileAddExpr: error in multiply expr} -body {
expr x*3
} -returnCodes error -match glob -result *
test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test expr-11.8 {CompileAddExpr: error compiling add arm} -body {
expr 2***3+6
} -returnCodes error -match glob -result *
test expr-11.9 {CompileAddExpr: error compiling add arm} -body {
expr 2-x
} -returnCodes error -match glob -result *
test expr-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {cannot use non-numeric string "xx" as right operand of "+"}}
test expr-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "-"}}
test expr-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13a {CompileAddExpr: runtime error} !ieeeFloatingPoint {
list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13b {CompileAddExpr: runtime error} ieeeFloatingPoint {
list [catch {expr {2.3/0.0}} msg] $msg
} {0 Inf}
test expr-11.14 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+[lseq 2 4]}} msg] $msg
} {1 {cannot use a list as right operand of "+"}}
test expr-11.15 {CompileAddExpr: runtime error} {
list [catch {expr {{1 2 "}+24.0}} msg] $msg
} {1 {cannot use non-numeric string "1 2 "" as left operand of "+"}}
test expr-11.16 {CompileAddExpr: runtime error} {
list [catch {expr {~[dict create foo bar]}} msg] $msg
} {1 {cannot use a list as operand of "~"}}
test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
test expr-12.5 {CompileMultiplyExpr: error in unary expr} -body {
expr ~x
} -returnCodes error -match glob -result *
test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*3%%6
} -returnCodes error -match glob -result *
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*x
} -returnCodes error -match glob -result *
test expr-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {cannot use non-numeric string "xx" as right operand of "*"}}
test expr-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "/"}}
test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83
test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test expr-13.8 {CompileUnaryExpr: error compiling unary expr} -body {
expr ~x
} -returnCodes error -match glob -result *
test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body {
expr !1.x
} -returnCodes error -match glob -result *
test expr-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
} {1 {cannot use non-numeric string "xx" as operand of "~"}}
test expr-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
} {1 {cannot use floating-point value "4.0" as operand of "~"}}
test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test expr-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
expr $a
} 27
test expr-13.14 {CompileUnaryExpr: just primary expr} {
expr double(27)
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
| | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
set i {}
}
set i
} {}
test expr-16.2 {GetToken: check for string literal in braces} {
expr {{1}}
} {1}
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
} { }
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
test expr-19.1 {expr and interpreter result object resetting} {
proc p {} {
| | | | | | | | | | | | | 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 |
} { }
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
test expr-19.1 {expr and interpreter result object resetting} {
proc p {} {
set t 10.0
set x 2.0
set dx 0.2
set f {$dx-$x/10}
set g {-$x/5}
set center 1.0
set x [expr $x-$center]
set dx [expr $dx+$g]
set x [expr $x+$f+$center]
set x [expr $x+$f+$center]
set y [expr round($x)]
}
p
} 3
# Test for incorrect "double evaluation" semantics
test expr-20.1 {wrong brace matching} {
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
proc exprtraceproc {args} {
upvar #0 exprtracecounter counter
set argc [llength $args]
set extraargs [lrange $args 0 [expr {$argc - 4}]]
set name [lindex $args [expr {$argc - 3}]]
upvar 1 $name var
if {[incr counter] % 2 == 1} {
| | | | | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
proc exprtraceproc {args} {
upvar #0 exprtracecounter counter
set argc [llength $args]
set extraargs [lrange $args 0 [expr {$argc - 4}]]
set name [lindex $args [expr {$argc - 3}]]
upvar 1 $name var
if {[incr counter] % 2 == 1} {
set var "$counter oops [concat $extraargs]"
} else {
set var "$counter + [concat $extraargs]"
}
}
trace add variable exprtracevar read [list exprtraceproc 10]
list [catch {expr "$exprtracevar + 20"} a] $a \
[catch {expr "$exprtracevar + 20"} b] $b \
[unset exprtracevar exprtracecounter]
} -match glob -result {1 * 0 32 {}}
test expr-20.3 {broken substitution of integer digits} {
# fails with 8.0.x, but not 8.1b2
list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
} {4096 1000}
test expr-20.4 {proper double evaluation compilation, error case} {
catch {unset a}; # make sure $a doesn't exist
|
| ︙ | ︙ | |||
798 799 800 801 802 803 804 |
list [catch {expr + {[incr]}} msg] $msg
} {1 {wrong # args: should be "incr varName ?increment?"}}
test expr-20.7 {handling of compile error in runtime case} {
list [catch {expr + {[error foo]}} msg] $msg
} {1 foo}
# Test for non-numeric boolean literal handling
| | | | | | | | | | | | | | | | | | | 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 |
list [catch {expr + {[incr]}} msg] $msg
} {1 {wrong # args: should be "incr varName ?increment?"}}
test expr-20.7 {handling of compile error in runtime case} {
list [catch {expr + {[error foo]}} msg] $msg
} {1 foo}
# Test for non-numeric boolean literal handling
test expr-21.1 {non-numeric boolean literals} {expr false } false
test expr-21.2 {non-numeric boolean literals} {expr true } true
test expr-21.3 {non-numeric boolean literals} {expr off } off
test expr-21.4 {non-numeric boolean literals} {expr on } on
test expr-21.5 {non-numeric boolean literals} {expr no } no
test expr-21.6 {non-numeric boolean literals} {expr yes } yes
test expr-21.7 {non-numeric boolean literals} {expr !false} 1
test expr-21.8 {non-numeric boolean literals} {expr !true } 0
test expr-21.9 {non-numeric boolean literals} {expr !off } 1
test expr-21.10 {non-numeric boolean literals} {expr !on } 0
test expr-21.11 {non-numeric boolean literals} {expr !no } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
test expr-21.13 {non-numeric boolean literals} -body {
expr !truef
} -returnCodes error -match glob -result *
test expr-21.14 {non-numeric boolean literals} {
list [catch {expr !"truef"} err] $err
} {1 {cannot use non-numeric string "truef" as operand of "!"}}
test expr-21.15 {non-numeric boolean variables} {
set v truef
list [catch {expr {!$v}} err] $err
} {1 {cannot use non-numeric string "truef" as operand of "!"}}
test expr-21.16 {non-numeric boolean variables} {
set v "true "
list [catch {expr {!$v}} err] $err
} {1 {cannot use non-numeric string "true " as operand of "!"}}
test expr-21.17 {non-numeric boolean variables} {
set v "tru"
list [catch {expr {!$v}} err] $err
} {0 0}
test expr-21.18 {non-numeric boolean variables} {
set v "fal"
list [catch {expr {!$v}} err] $err
} {0 1}
test expr-21.19 {non-numeric boolean variables} {
set v "y"
list [catch {expr {!$v}} err] $err
} {0 0}
test expr-21.20 {non-numeric boolean variables} {
set v "of"
list [catch {expr {!$v}} err] $err
} {0 1}
test expr-21.21 {non-numeric boolean variables} {
set v "o"
list [catch {expr {!$v}} err] $err
} {1 {cannot use non-numeric string "o" as operand of "!"}}
test expr-21.22 {non-numeric boolean variables} {
set v ""
list [catch {expr {!$v}} err] $err
} {1 {cannot use non-numeric string "" as operand of "!"}}
# Test for non-numeric float handling.
test expr-22.1 {non-numeric floats} {
list [catch {expr {NaN + 1}} msg] $msg
} {1 {cannot use non-numeric floating-point value "NaN" as left operand of "+"}}
test expr-22.2 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} {
set nan NaN
list [catch {expr {$nan + 1}} msg] $msg
} {1 {cannot use non-numeric floating-point value "NaN" as left operand of "+"}}
test expr-22.4 {non-numeric floats} !ieeeFloatingPoint {
set inf Inf
list [catch {expr {$inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.5 {non-numeric floats} {
list [catch {expr NaN} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-22.6 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr Inf} msg] $msg
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} {
list [catch {expr {1 / NaN}} msg] $msg
} {1 {cannot use non-numeric floating-point value "NaN" as right operand of "/"}}
test expr-22.8 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
# Make sure [Bug 761471] stays fixed.
test expr-22.9 {non-numeric floats: shared object equality and NaN} {
set x NaN
expr {$x == $x}
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 |
expr (-3-)**6
} -returnCodes error -match glob -result *
test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body {
expr 2**x
} -returnCodes error -match glob -result *
test expr-23.9 {CompileExponentialExpr: runtime error} {
list [catch {expr {24.0**"xx"}} msg] $msg
| | | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 |
expr (-3-)**6
} -returnCodes error -match glob -result *
test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body {
expr 2**x
} -returnCodes error -match glob -result *
test expr-23.9 {CompileExponentialExpr: runtime error} {
list [catch {expr {24.0**"xx"}} msg] $msg
} {1 {cannot use non-numeric string "xx" as right operand of "**"}}
test expr-23.10 {CompileExponentialExpr: runtime error} {
list [catch {expr {"a"**2}} msg] $msg
} {1 {cannot use non-numeric string "a" as left operand of "**"}}
test expr-23.11 {CompileExponentialExpr: runtime error} {
list [catch {expr {0**-1}} msg] $msg
} {1 {exponentiation of zero by negative power}}
test expr-23.12 {CompileExponentialExpr: runtime error} {
list [catch {expr {0.0**-1.0}} msg] $msg
} {1 {exponentiation of zero by negative power}}
test expr-23.13 {CompileExponentialExpr: runtime error} {
|
| ︙ | ︙ | |||
5723 5724 5725 5726 5727 5728 5729 |
test expr-31.14 {boolean conversion} {expr bool(wide(5))} 1
test expr-31.15 {boolean conversion} -body {
expr bool("fred")
} -returnCodes error -match glob -result *
test expr-32.1 {expr mod basics} {
set mod_nums [list \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 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 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 |
test expr-31.14 {boolean conversion} {expr bool(wide(5))} 1
test expr-31.15 {boolean conversion} -body {
expr bool("fred")
} -returnCodes error -match glob -result *
test expr-32.1 {expr mod basics} {
set mod_nums [list \
{-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \
{-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \
{-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \
{-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \
{-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \
{-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \
{0 -100} {0 -1} {0 1} {0 100} \
{1 1} {1 2} {1 3} {1 4} {1 5} \
{1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \
{2 1} {2 2} {2 3} {2 4} {2 5} \
{2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \
{3 1} {3 2} {3 3} {3 4} {3 5} \
{3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \
]
set results [list]
foreach pair $mod_nums {
set dividend [lindex $pair 0]
set divisor [lindex $pair 1]
lappend results [expr {$dividend % $divisor}]
}
set results
} [list \
0 1 0 1 2 \
0 -1 0 -3 -3 \
0 0 1 2 3 \
0 0 -2 -2 -2 \
0 1 2 3 4 \
0 -1 -1 -1 -1 \
0 0 0 0 \
0 1 1 1 1 \
0 -1 -2 -3 -4 \
0 0 2 2 2 \
0 0 -1 -2 -3 \
0 1 0 3 3 \
0 -1 0 -1 -2 \
]
test expr-32.2 {expr div basics} {
set mod_nums [list \
{-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \
{-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \
{-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \
{-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \
{-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \
{-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \
{0 -100} {0 -1} {0 1} {0 100} \
{1 1} {1 2} {1 3} {1 4} {1 5} \
{1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \
{2 1} {2 2} {2 3} {2 4} {2 5} \
{2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \
{3 1} {3 2} {3 3} {3 4} {3 5} \
{3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \
]
set results [list]
foreach pair $mod_nums {
set dividend [lindex $pair 0]
set divisor [lindex $pair 1]
lappend results [expr {$dividend / $divisor}]
}
set results
} [list \
-3 -2 -1 -1 -1 \
3 1 1 0 0 \
-2 -1 -1 -1 -1 \
2 1 0 0 0 \
|
| ︙ | ︙ | |||
5830 5831 5832 5833 5834 5835 5836 |
set max_long_hex "0x7FFFFFFF "
# Convert to integer (long, not wide) internal rep
set max_long 2147483647
string is integer $max_long
list \
| | | | | | | | | | | | | | | | | | | | | | | | | | | 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 |
set max_long_hex "0x7FFFFFFF "
# Convert to integer (long, not wide) internal rep
set max_long 2147483647
string is integer $max_long
list \
[expr {" $max_long_str "}] \
[expr {$max_long_str + 0}] \
[expr {$max_long + 0}] \
[expr {2147483647 + 0}] \
[expr {$max_long == $max_long_hex}] \
[expr {int(2147483647 + 1) > 0}] \
} {2147483647 2147483647 2147483647 2147483647 1 1}
test expr-33.2 {parse smallest long value} {
set min_long_str -2147483648
set min_long_hex "-0x80000000 "
set min_long -2147483648
# This will convert to integer (not wide) internal rep
string is integer $min_long
# Note: If the final expression returns 0 then the
# expression literal is being promoted to a wide type
# when it should be parsed as a long type.
list \
[expr {" $min_long_str "}] \
[expr {$min_long_str + 0}] \
[expr {$min_long + 0}] \
[expr {-2147483648 + 0}] \
[expr {$min_long == $min_long_hex}] \
[expr {int(-2147483648 - 1) == -0x80000001}] \
} {-2147483648 -2147483648 -2147483648 -2147483648 1 1}
test expr-33.3 {parse largest wide value} wideIs64bit {
set max_wide_str 9223372036854775807
set max_wide_hex "0x7FFFFFFFFFFFFFFF "
# Convert to wide integer
set max_wide 9223372036854775807
string is integer $max_wide
list \
[expr {" $max_wide_str "}] \
[expr {$max_wide_str + 0}] \
[expr {$max_wide + 0}] \
[expr {9223372036854775807 + 0}] \
[expr {$max_wide == $max_wide_hex}] \
[expr {wide(9223372036854775807 + 1) < 0}] \
} {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1}
test expr-33.4 {parse smallest wide value} wideIs64bit {
set min_wide_str -9223372036854775808
set min_wide_hex "-0x8000000000000000 "
set min_wide -9223372036854775808
# Convert to wide integer
string is integer $min_wide
# Note: If the final expression returns 0 then the
# wide integer is not being parsed correctly with
# the leading - sign.
list \
[expr {" $min_wide_str "}] \
[expr {$min_wide_str + 0}] \
[expr {$min_wide + 0}] \
[expr {-9223372036854775808 + 0}] \
[expr {$min_wide == $min_wide_hex}] \
[expr {wide(-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \
} {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1}
set min -2147483648
set max 2147483647
test expr-34.1 {expr edge cases} {
|
| ︙ | ︙ | |||
7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 |
if {$k != (1<<28)+1} {
append trouble "i = $i, k = $k\n"
incr faults
}
}
set trouble
} {}
test expr-48.1 {Bug 1770224} {
expr {-0x8000000000000001 >> 0x8000000000000000}
} -1
test expr-49.1 {Bug 2823282} {
coroutine foo apply {{} {set expr expr; $expr {[yield]}}}
| > > > > > > > > > | 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 |
if {$k != (1<<28)+1} {
append trouble "i = $i, k = $k\n"
incr faults
}
}
set trouble
} {}
test expr-47.14 {isqrt() - lseq} {
list [catch {expr {isqrt([lseq 1 3])}} result] $result
} {1 {expected number but got a list}}
test expr-47.15 {isqrt() - lseq} {
list [catch {expr {isqrt({1 2 "})}} result] $result
} {1 {expected number but got "1 2 ""}}
test expr-47.16 {isqrt() - lseq} {
list [catch {expr {isqrt([dict create foo bar])}} result] $result
} {1 {expected number but got a list}}
test expr-48.1 {Bug 1770224} {
expr {-0x8000000000000001 >> 0x8000000000000000}
} -1
test expr-49.1 {Bug 2823282} {
coroutine foo apply {{} {set expr expr; $expr {[yield]}}}
|
| ︙ | ︙ | |||
7271 7272 7273 7274 7275 7276 7277 |
expr ${func}(1.0)
} -match glob -result *
test expr-53.6.$func {float classification: basic arg handling} -body {
expr ${func}(0x123)
} -match glob -result *
}
| | > > > > > > > | < > > > | | | | > > > > > | | > | | < < < < < < < < < < > | > > | > > | > > | > > | | > | | > | > > | > > | > > | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < | 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 |
expr ${func}(1.0)
} -match glob -result *
test expr-53.6.$func {float classification: basic arg handling} -body {
expr ${func}(0x123)
} -match glob -result *
}
foreach {v r} {
1 normal
-1 normal
0x7fffffffffffffff normal
-0x7fffffffffffffff normal
0xffffffffffffffffff normal
-0xffffffffffffffffff normal
1.0 normal
-1.0 normal
0 zero
-0 zero
0.0 zero
-0.0 zero
1/Inf zero
-1/Inf zero
1e-314 subnormal
-1e-314 subnormal
.0999999**319 subnormal
-.0999999**319 subnormal
1e-320/.9 subnormal
-1e-320/.9 subnormal
1e5555 infinite
1e308**1e10 infinite
Inf infinite
-1e5555 infinite
-1e308**(1e10+1) infinite
-Inf infinite
NaN nan
} {
if {[regexp {[/\*]} $v]} { set v [expr $v] }
test expr-58.1($v)=$r "float classification: fpclassify($v) eq $r" {
fpclassify $v
} $r
test expr-58.2($v) "float classification: isfinite($v)" {
expr {isfinite($v)}
} [expr {$r ni {"infinite" "nan"}}]
test expr-58.3($v) "float classification: isinf($v)" {
expr {isinf($v)}
} [expr {$r eq "infinite"}]
test expr-58.4($v) "float classification: isnan($v)" {
expr {isnan($v)}
} [expr {$r eq "nan"}]
test expr-58.5($v) "float classification: isnormal($v)" {
expr {isnormal($v)}
} [expr {$r eq "normal"}]
test expr-58.6($v) "float classification: issubnormal($v)" {
expr {issubnormal($v)}
} [expr {$r eq "subnormal"}]
test expr-58.7($v) "float classification: isunordered(0 and $v)" {
expr {isunordered(0,$v) + isunordered($v,0)}
} [expr {$r eq "nan" ? 2 : 0}]
test expr-58.9($v) "float classification: isunordered(NaN and $v)" {
expr {isunordered(NaN,$v) + isunordered($v,NaN)}
} 2
}
unset -nocomplain v r
test expr-59.10 {float classification: fpclassify} -returnCodes error -body {
fpclassify
} -result {wrong # args: should be "fpclassify floatValue"}
test expr-59.11 {float classification: fpclassify} -returnCodes error -body {
fpclassify a b
} -result {wrong # args: should be "fpclassify floatValue"}
test expr-59.12 {float classification: fpclassify} -returnCodes error -body {
|
| ︙ | ︙ | |||
7361 7362 7363 7364 7365 7366 7367 |
} -returnCodes error -result {too many arguments for math function "isunordered"}
test expr-60.4 {float classification: basic arg handling} -body {
expr {isunordered(true, 1.0)}
} -returnCodes error -result {expected number but got "true"}
test expr-60.5 {float classification: basic arg handling} -body {
expr {isunordered("gorp", 1.0)}
} -returnCodes error -result {expected number but got "gorp"}
| | | | > > > | | | | < < < < < < < | < < < | | 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 |
} -returnCodes error -result {too many arguments for math function "isunordered"}
test expr-60.4 {float classification: basic arg handling} -body {
expr {isunordered(true, 1.0)}
} -returnCodes error -result {expected number but got "true"}
test expr-60.5 {float classification: basic arg handling} -body {
expr {isunordered("gorp", 1.0)}
} -returnCodes error -result {expected number but got "gorp"}
test expr-60.6a {float classification: basic arg handling, large bigint -> double and wide} -body {
expr "isunordered(0x[string repeat f 100], 0x7fffffffffffffff)"
} -result 0
test expr-60.6b {float classification: basic arg handling, large bigint -> double Inf and wide} -body {
expr "isunordered(0x[string repeat f 1000], 0x7fffffffffffffff)"
} -result 0
test expr-60.7 {float classification: basic arg handling} -body {
expr {isunordered(1.0, true)}
} -returnCodes error -result {expected number but got "true"}
test expr-60.8 {float classification: basic arg handling} -body {
expr {isunordered(1.0, "gorp")}
} -returnCodes error -result {expected number but got "gorp"}
test expr-60.9a {float classification: basic arg handling, wide and large bigint -> double} -body {
expr "isunordered(0x7fffffffffffffff, 0x[string repeat f 100])"
} -result 0
test expr-60.9b {float classification: basic arg handling, wide and large bigint -> double Inf} -body {
expr "isunordered(0x7fffffffffffffff, 0x[string repeat f 1000])"
} -result 0
test expr-62.1 {TIP 582: comments} -body {
expr {1 # + 2}
} -result 1
test expr-62.2 {TIP 582: comments} -body {
expr "1 #\n+ 2"
} -result 3
|
| ︙ | ︙ |
Changes to tests/fCmd.test.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
} on error {} {
# try the location given to use on the commandline to tcltest
::tcltest::loadTestedCommands
load $::reglib Registry
}
testConstraint reg 1
} regError]} {
| | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
} on error {} {
# try the location given to use on the commandline to tcltest
::tcltest::loadTestedCommands
load $::reglib Registry
}
testConstraint reg 1
} regError]} {
catch {package require registry; testConstraint reg 1}
}
}
testConstraint notInCIenv [expr {![info exists ::env(CI)] || !$::env(CI)}]
# File permissions broken on wsl without some "exotic" wsl configuration
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 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 |
testConstraint notDarwin9 [expr {![testConstraint darwin9]}]
testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}]
testConstraint fileSharing 0
testConstraint notFileSharing 1
testConstraint linkFile 1
testConstraint linkDirectory 1
# Several tests require need to match results against the Unix username
set user {}
if {[testConstraint unix]} {
catch {
set user [exec whoami]
}
if {$user eq ""} {
catch {
regexp {^[^(]*\(([^)]*)\)} [exec id] -> user
}
}
if {$user eq ""} {
set user "root"
}
}
if {[testConstraint win]} {
catch {
| > | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
testConstraint notDarwin9 [expr {![testConstraint darwin9]}]
testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}]
testConstraint fileSharing 0
testConstraint notFileSharing 1
testConstraint linkFile 1
testConstraint linkDirectory 1
testConstraint testfstildeexpand [llength [info commands testfstildeexpand]]
# Several tests require need to match results against the Unix username
set user {}
if {[testConstraint unix]} {
catch {
set user [exec whoami]
}
if {$user eq ""} {
catch {
regexp {^[^(]*\(([^)]*)\)} [exec id] -> user
}
}
if {$user eq ""} {
set user "root"
}
}
if {[testConstraint win]} {
catch {
set user $::env(USERNAME)
}
if {$user eq ""} {
set user Administrator
}
}
# Try getting a lower case glob pattern that will match the home directory of
# a given user to test ~user and [file tildeexpand ~user]. Note this may not
# be the same as ~ even when "user" is current user. For example, on Unix
# platforms ~ will return HOME envvar, but ~user will lookup password file
# bypassing HOME. If home directory not found, returns *$user* so caller can
# succeed by using glob matching under the hope that the path contains
# the user name.
proc gethomedirglob {user} {
if {[testConstraint unix]} {
if {![catch {
exec {*}[auto_execok sh] -c "echo ~$user"
} home]} {
set home [string trim $home]
if {$home ne ""} {
# Expect exact match (except case), no glob * added
return [string tolower $home]
}
}
} elseif {[testConstraint reg]} {
# Windows with registry extension loaded
if {![catch {
set sid [exec {*}[auto_execok powershell] -Command "(Get-LocalUser -Name '$user')\[0\].sid.Value"]
set sid [string trim $sid]
# Get path from the Windows registry
set home [registry get "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\ProfileList\\$sid" ProfileImagePath]
set home [string trim [string tolower $home]]
} result]} {
if {$home ne ""} {
# file join for \ -> /
return [file join [string tolower $home]]
}
}
}
# Caller will need to use glob matching and hope user
# name is in the home directory path
return *[string tolower $user]*
}
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 |
}
return [string match $matchString $fileString]
}
proc openup {path} {
# Double check for inadvertent ~ -> home directory mapping
if {[string match ~* $path]} {
| | | | | | | 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 |
}
return [string match $matchString $fileString]
}
proc openup {path} {
# Double check for inadvertent ~ -> home directory mapping
if {[string match ~* $path]} {
set file ./$path
}
testchmod 0o777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
openup $p
}
}
}
}
proc cleanup {args} {
set wd [list .]
foreach p [concat $wd $args] {
set x ""
catch {
set x [glob -directory $p tf* td* ~*]
}
foreach file $x {
# Double check for inadvertent ~ -> home directory mapping
if {[string match ~* $file]} {
set file ./$file
}
if {
[catch {file delete -force -- $file}]
&& [testConstraint testchmod]
} then {
catch {openup $file}
catch {file delete -force -- $file}
}
|
| ︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 |
createfile tfs3
createfile tfs4
createfile tfd1
createfile tfd2
createfile tfd3
createfile tfd4
if {$::tcl_platform(platform) eq "windows"} {
| | | | | | | | | | | | 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 |
createfile tfs3
createfile tfs4
createfile tfd1
createfile tfd2
createfile tfd3
createfile tfd4
if {$::tcl_platform(platform) eq "windows"} {
# On Windows testchmode will attach an ACL which file copy cannot handle
# so use good old attributes which file copy does understand
file attribute tfs3 -readonly 1
file attribute tfs4 -readonly 1
file attribute tfd2 -readonly 1
file attribute tfd4 -readonly 1
} else {
testchmod 0o444 tfs3
testchmod 0o444 tfs4
testchmod 0o444 tfd2
testchmod 0o444 tfd4
}
set msg [list [catch {file copy tf1 tf2} msg] $msg]
file copy -force tfs1 tfd1
file copy -force tfs2 tfd2
file copy -force tfs3 tfd3
file copy -force tfs4 tfd4
list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
|
| ︙ | ︙ | |||
2691 2692 2693 2694 2695 2696 2697 |
# Get the localized version of the folder name by looking in the registry.
set mydocsname [registry get {HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders} Personal]
} -constraints {win reg} -body {
file writable $mydocsname
} -result 1
test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win notWine} -body {
expr {[info exists env(USERPROFILE)]
| | | | | | | | 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 |
# Get the localized version of the folder name by looking in the registry.
set mydocsname [registry get {HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders} Personal]
} -constraints {win reg} -body {
file writable $mydocsname
} -result 1
test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win notWine} -body {
expr {[info exists env(USERPROFILE)]
&& [file exists $env(USERPROFILE)/NTUSER.DAT]
&& [file readable $env(USERPROFILE)/NTUSER.DAT]}
} -result 1
# At least one CI environment (GitHub Actions) is set up with the page file in
# an unusual location; skip the test if that is so.
test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} -body {
set r {}
if {[info exists env(SystemDrive)]} {
set path $env(SystemDrive)/pagefile.sys
lappend r exists [file exists $path]
lappend r readable [file readable $path]
lappend r stat [catch {file stat $path a} e] $e
}
return $r
} -result {exists 1 readable 0 stat 0 {}}
test fCmd-31.1 {file home} -body {
file home
} -result [file join $::env(HOME)]
|
| ︙ | ︙ | |||
2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 |
set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
string tolower [file home $::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
test fCmd-32.1 {file tildeexpand ~} -body {
file tildeexpand ~
} -result [file join $::env(HOME)]
test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
file tildeexpand ~
} -result [file join $::env(HOME) xxx]
test fCmd-32.3 {file tildeexpand ~ - error} -setup {
set saved $::env(HOME)
unset ::env(HOME)
} -cleanup {
set ::env(HOME) $saved
} -body {
file tildeexpand ~
} -returnCodes error -result {couldn't find HOME environment variable to expand path}
test fCmd-32.4 {
file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative
paths are not made absolute
} -setup {
set saved $::env(HOME)
set ::env(HOME) relative/path
} -cleanup {
set ::env(HOME) $saved
} -body {
file tildeexpand ~
} -result relative/path
test fCmd-32.5 {file tildeexpand ~USER} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [file tildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body {
file tildeexpand ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.7 {file tildeexpand ~extra arg} -body {
file tildeexpand ~ arg
} -returnCodes error -result {wrong # args: should be "file tildeexpand path"}
test fCmd-32.8 {file tildeexpand ~/path} -body {
file tildeexpand ~/foo
} -result [file join $::env(HOME)/foo]
test fCmd-32.9 {file tildeexpand ~USER/bar} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [file tildeexpand ~$::tcl_platform(user)/bar]
} -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body {
file tildeexpand ~nosuchuser/foo
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.11 {file tildeexpand /~/path} -body {
file tildeexpand /~/foo
} -result /~/foo
test fCmd-32.12 {file tildeexpand /~user/path} -body {
file tildeexpand /~$::tcl_platform(user)/foo
} -result /~$::tcl_platform(user)/foo
test fCmd-32.13 {file tildeexpand ./~} -body {
file tildeexpand ./~
} -result ./~
test fCmd-32.14 {file tildeexpand relative/path} -body {
file tildeexpand relative/path
} -result relative/path
test fCmd-32.15 {file tildeexpand ~\\path} -body {
file tildeexpand ~\\foo
} -constraints win -result [file join $::env(HOME)/foo]
test fCmd-32.16 {file tildeexpand ~USER\\bar} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [file tildeexpand ~$::tcl_platform(user)\\bar]
} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup {
set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
string tolower [file tildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
# cleanup
cleanup
if {[testConstraint unix]} {
removeDirectory tcl[pid] /tmp
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 |
set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
string tolower [file home $::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
# file tildeexpand and testfstildexpand are identical in behavior
# but tested separately as the former is a script wrapper that does some
# sanitization/optimization while the latter is a raw call to Tcl_FSTildeExpand.
test fCmd-32.1 {file tildeexpand ~} -body {
file tildeexpand ~
} -result [file join $::env(HOME)]
test fCmd-32.1.1 {Tcl_FSTildeExpand ~} -constraints testfstildeexpand -body {
testfstildeexpand ~
} -result [file join $::env(HOME)]
test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
file tildeexpand ~
} -result [file join $::env(HOME) xxx]
test fCmd-32.2.1 {Tcl_FSTildeExpand ~ - obeys env} -setup {
set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -constraints testfstildeexpand -body {
testfstildeexpand ~
} -result [file join $::env(HOME) xxx]
test fCmd-32.3 {file tildeexpand ~ - error} -setup {
set saved $::env(HOME)
unset ::env(HOME)
} -cleanup {
set ::env(HOME) $saved
} -body {
file tildeexpand ~
} -returnCodes error -result {couldn't find HOME environment variable to expand path}
test fCmd-32.3.1 {Tcl_FSTildeExpand ~ - error} -setup {
set saved $::env(HOME)
unset ::env(HOME)
} -cleanup {
set ::env(HOME) $saved
} -constraints testfstildeexpand -body {
testfstildeexpand ~
} -returnCodes error -result {couldn't find HOME environment variable to expand path}
test fCmd-32.4 {
file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative
paths are not made absolute
} -setup {
set saved $::env(HOME)
set ::env(HOME) relative/path
} -cleanup {
set ::env(HOME) $saved
} -body {
file tildeexpand ~
} -result relative/path
test fCmd-32.4.1 {
Tcl_FSTildeExpand ~ - relative path. Following 8.x ~ expansion behavior, relative
paths are not made absolute
} -setup {
set saved $::env(HOME)
set ::env(HOME) relative/path
} -cleanup {
set ::env(HOME) $saved
} -constraints testfstildeexpand -body {
testfstildeexpand ~
} -result relative/path
test fCmd-32.5 {file tildeexpand ~USER} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [file tildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
test fCmd-32.5.1 {Tcl_FSTildeExpand ~USER} -constraints testfstildeexpand -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [testfstildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body {
file tildeexpand ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.6.1 {Tcl_FSTildeExpand ~UNKNOWNUSER} -constraints testfstildeexpand -body {
testfstildeexpand ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.7 {file tildeexpand ~extra arg} -body {
file tildeexpand ~ arg
} -returnCodes error -result {wrong # args: should be "file tildeexpand path"}
test fCmd-32.7.1 {Tcl_FSTildeExpand ~extra arg} -constraints testfstildeexpand -body {
testfstildeexpand ~ arg
} -returnCodes error -result {wrong # args: should be "testfstildeexpand PATH"}
test fCmd-32.8 {file tildeexpand ~/path} -body {
file tildeexpand ~/foo
} -result [file join $::env(HOME)/foo]
test fCmd-32.8.1 {Tcl_FSTildeExpand ~/path} -constraints testfstildeexpand -body {
testfstildeexpand ~/foo
} -result [file join $::env(HOME)/foo]
test fCmd-32.9 {file tildeexpand ~USER/bar} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [file tildeexpand ~$::tcl_platform(user)/bar]
} -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
test fCmd-32.9.1 {Tcl_FSTildeExpand ~USER/bar} -constraints testfstildeexpand -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [testfstildeexpand ~$::tcl_platform(user)/bar]
} -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body {
file tildeexpand ~nosuchuser/foo
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.10.1 {Tcl_FSTildeExpand ~UNKNOWNUSER} -constraints testfstildeexpand -body {
testfstildeexpand ~nosuchuser/foo
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.11 {file tildeexpand /~/path} -body {
file tildeexpand /~/foo
} -result /~/foo
test fCmd-32.11.1 {Tcl_FSTildeExpand /~/path} -constraints testfstildeexpand -body {
testfstildeexpand /~/foo
} -result /~/foo
test fCmd-32.12 {file tildeexpand /~user/path} -body {
file tildeexpand /~$::tcl_platform(user)/foo
} -result /~$::tcl_platform(user)/foo
test fCmd-32.12.1 {Tcl_FSTildeExpand /~user/path} -constraints testfstildeexpand -body {
testfstildeexpand /~$::tcl_platform(user)/foo
} -result /~$::tcl_platform(user)/foo
test fCmd-32.13 {file tildeexpand ./~} -body {
file tildeexpand ./~
} -result ./~
test fCmd-32.13.1 {Tcl_FSTildeExpand ./~} -constraints testfstildeexpand -body {
testfstildeexpand ./~
} -result ./~
test fCmd-32.14 {file tildeexpand relative/path} -body {
file tildeexpand relative/path
} -result relative/path
test fCmd-32.14.1 {Tcl_FSTildeExpand relative/path} -constraints testfstildeexpand -body {
testfstildeexpand relative/path
} -result relative/path
test fCmd-32.15 {file tildeexpand ~\\path} -body {
file tildeexpand ~\\foo
} -constraints win -result [file join $::env(HOME)/foo]
test fCmd-32.15.1 {Tcl_FSTildeExpand ~\\path} -constraints testfstildeexpand -body {
testfstildeexpand ~\\foo
} -constraints win -result [file join $::env(HOME)/foo]
test fCmd-32.16 {file tildeexpand ~USER\\bar} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [file tildeexpand ~$::tcl_platform(user)\\bar]
} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
test fCmd-32.16.1 {Tcl_FSTildeExpand ~USER\\bar} -constraints testfstildeexpand -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
string tolower [testfstildeexpand ~$::tcl_platform(user)\\bar]
} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup {
set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
string tolower [file tildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
test fCmd-32.17.1 {Tcl_FSTildeExpand ~USER does not mirror HOME} -setup {
set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -constraints testfstildeexpand -body {
string tolower [testfstildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
# cleanup
cleanup
if {[testConstraint unix]} {
removeDirectory tcl[pid] /tmp
|
| ︙ | ︙ |
Changes to tests/fileName.test.
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
} globTest/a1/
test filename-14.31 {Bug 2918610} -setup {
set d [makeDirectory foo]
makeFile {} bar.soom $d
} -body {
foreach fn [glob $d/bar.soom] {
| | | | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 |
} globTest/a1/
test filename-14.31 {Bug 2918610} -setup {
set d [makeDirectory foo]
makeFile {} bar.soom $d
} -body {
foreach fn [glob $d/bar.soom] {
set root [file rootname $fn]
close [open $root {WRONLY CREAT}]
}
llength [glob -directory $d *]
} -cleanup {
file delete -force $d/bar
removeFile bar.soom $d
removeDirectory foo
} -result 2
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
} {absolute absolute absolute absolute absolute absolute relative}
if {[testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-17.2 {windows specific glob with executable} -body {
makeDirectory execglob
foreach ext {exe com cmd bat notexecutable} {
| | | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 |
} {absolute absolute absolute absolute absolute absolute relative}
if {[testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-17.2 {windows specific glob with executable} -body {
makeDirectory execglob
foreach ext {exe com cmd bat notexecutable} {
makeFile contents execglob/abc.$ext
}
lsort [glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x *]
} -constraints {win} -cleanup {
foreach ext {exe com cmd bat ps1 notexecutable} {
removeFile execglob/abc.$ext
}
removeDirectory execglob
} -result {abc.bat abc.cmd abc.com abc.exe}
test filename-17.3 {Bug 2571597} win {
set p /a
file pathtype $p
file normalize $p
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
set ::ddelib [info loaded {} Dde]
set ::regver [package require registry]
set ::reglib [info loaded {} Registry]
testConstraint loaddll [expr {$::ddelib ne "" && $::reglib ne ""}]
}
# Test for commands defined in tcl::test package
| | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
set ::ddelib [info loaded {} Dde]
set ::regver [package require registry]
set ::reglib [info loaded {} Registry]
testConstraint loaddll [expr {$::ddelib ne "" && $::reglib ne ""}]
}
# Test for commands defined in tcl::test package
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
# Some things fail under all Continuous Integration systems for subtle reasons
# such as CI often running with elevated privileges in a container.
testConstraint notInCIenv [expr {![info exists ::env(CI)]}]
cd [tcltest::temporaryDirectory]
makeFile "test file" gorp.file
|
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
testConstraint unusedDrive 1
break
}
}
set dir [pwd]
try {
| | | | | | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
testConstraint unusedDrive 1
break
}
}
set dir [pwd]
try {
set drives [lmap vol [file volumes] {
if {$vol eq [zipfs root] || [catch {cd $vol}]} {
continue
}
set vol
}]
testConstraint moreThanOneDrive [expr {[llength $drives] > 1}]
} finally {
cd $dir
}
}
} ::tcl::test::fileSystem}
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
file normalize ~noonewiththisname
} -result [file join [pwd] ~noonewiththisname]
test filesystem-1.30.1 {normalisation of existing user} -body {
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)
| | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
file normalize ~noonewiththisname
} -result [file join [pwd] ~noonewiththisname]
test filesystem-1.30.1 {normalisation of existing user} -body {
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 normalize [file home $::tcl_platform(user)]]
set ::env(HOME) [file join $oldhome temp]
} -cleanup {
set ::env(HOME) $oldhome
} -body {
list [string equal [file normalize [file home]] [file normalize $::env(HOME)]] \
[string equal $olduserhome [file normalize [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
} {/bar}
test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} {
testsetplatform unix
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
| > | > > > > > > > | > > > > > > | 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 |
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
if {[file dirname $::ddelib] ne "."} {
cd [file dirname $::ddelib]
} else {
cd [file dirname [info nameofexecutable]]
}
if {![file exists [file tail $::ddelib]]} {
::tcltest::Skip "no-ddelib"
}
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
load simplefs:/[file tail $::ddelib] Dde
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
} -cleanup {
cd $dir
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
if {[file dirname $::reglib] ne "."} {
cd [file dirname $::reglib]
} else {
cd [file dirname [info nameofexecutable]]
}
if {![file exists [file tail $::reglib]]} {
::tcltest::Skip "no-reglib"
}
testsimplefilesystem 1
# This loads reg via a complex copy-to-temp operation
load simplefs:/[file tail $::reglib] Registry
unload simplefs:/[file tail $::reglib]
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
|
| ︙ | ︙ |
Changes to tests/for.test.
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
}
set a
} {2}
test for-2.5 {continue tests, nested loops} {
set msg {}
for {set i 1} {$i <= 4} {incr i} {
for {set a 1} {$a <= 2} {incr a} {
| | | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
}
set a
} {2}
test for-2.5 {continue tests, nested loops} {
set msg {}
for {set i 1} {$i <= 4} {incr i} {
for {set a 1} {$a <= 2} {incr a} {
if {$i>=2 && $a>=2} continue
set msg [concat $msg "$i.$a"]
}
}
set msg
} {1.1 1.2 2.1 3.1 4.1}
test for-2.6 {continue tests, long command body} {
set a {}
for {set i 1} {$i<6} {incr i} {
if {$i==2} continue
|
| ︙ | ︙ | |||
201 202 203 204 205 206 207 |
}
set a [concat $a $i]
}
set a
} {1 3}
test for-2.7 {continue tests, uncompiled [for]} -body {
set file [makeFile {
| | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
}
set a [concat $a $i]
}
set a
} {1 3}
test for-2.7 {continue tests, uncompiled [for]} -body {
set file [makeFile {
set guard 0
for {set i 20} {$i > 0} {incr i -1} {
if {[incr guard]>30} {return BAD}
continue
}
return GOOD
} source.file]
source $file
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
}
set a
} {1 2}
test for-3.4 {break tests, nested loops} {
set msg {}
for {set i 1} {$i <= 4} {incr i} {
for {set a 1} {$a <= 2} {incr a} {
| | | | | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
}
set a
} {1 2}
test for-3.4 {break tests, nested loops} {
set msg {}
for {set i 1} {$i <= 4} {incr i} {
for {set a 1} {$a <= 2} {incr a} {
if {$i>=2 && $a>=2} break
set msg [concat $msg "$i.$a"]
}
}
set msg
} {1.1 1.2 2.1 3.1 4.1}
test for-3.5 {break tests, long command body} {
set a {}
for {set i 1} {$i<6} {incr i} {
if {$i==2} continue
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
}
set a
} {1 3}
# A simplified version of exmh's mail formatting routine to stress "for",
# "break", "while", and "if".
proc formatMail {} {
array set lines {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}
set a
} {1 3}
# A simplified version of exmh's mail formatting routine to stress "for",
# "break", "while", and "if".
proc formatMail {} {
array set lines {
0 {Return-path: george@tcl} \
1 {Return-path: <george@tcl>} \
2 {Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4)} \
3 { id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700} \
4 {Message-id: <199609111814.LAA10027@tcl.Somewhere.COM>} \
5 {X-mailer: exmh version 1.6.9 8/22/96} \
6 {Mime-version: 1.0} \
7 {Content-type: text/plain; charset=iso-8859-1} \
8 {Content-transfer-encoding: quoted-printable} \
9 {Content-length: 2162} \
10 {To: fred} \
11 {Subject: tcl7.6} \
12 {Date: Wed, 11 Sep 1996 11:14:53 -0700} \
13 {From: George <george@tcl>} \
14 {The Tcl 7.6 and Tk 4.2 releases} \
15 {} \
16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} \
17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} \
18 {releases were released on August 30, 1996. These releases contain only minor changes,} \
19 {so we hope to have only a single beta release and to go final in early October, 1996.} \
20 {} \
21 {} \
22 {What's new} \
23 {} \
24 {The most important changes in the releases are summarized below. See the README} \
25 {and changes files in the distributions for more complete information on what has} \
26 {changed, including both feature changes and bug fixes.} \
27 {} \
28 { There are new options to the file command for copying files (file copy),} \
29 { deleting files and directories (file delete), creating directories (file} \
30 { mkdir), and renaming files (file rename).} \
31 { The implementation of exec has been improved greatly for Windows 95 and} \
32 { Windows NT.} \
33 { There is a new memory allocator for the Macintosh version, which should be} \
34 { more efficient than the old one.} \
35 { Tk's grid geometry manager has been completely rewritten. The layout} \
36 { algorithm produces much better layouts than before, especially where rows or} \
37 { columns were stretchable.} \
38 { There are new commands for creating common dialog boxes:} \
39 { tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} \
40 { tk_messageBox. These use native dialog boxes if they are available.} \
41 { There is a new virtual event mechanism for handling events in a more portable} \
42 { way. See the new command event. It also allows events (both physical and} \
43 { virtual) to be generated dynamically.} \
44 {} \
45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} \
46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \
47 {should work on these new releases as well.} \
48 {} \
49 {Obtaining The Releases} \
50 {} \
51 {Binary Releases} \
52 {} \
53 {Precompiled releases are available for the following platforms: } \
54 {} \
55 { Windows 3.1, Windows 95, and Windows NT: Fetch} \
56 { ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \
57 { self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \
58 { tclsh programs, and documentation.} \
59 { Macintosh (both 68K and PowerPC): Fetch} \
60 { ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \
61 { which is understood by Fetch, StuffIt, and many other Mac utilities. The} \
62 { unpacked file is a self-installing executable: double-click on it and it will create a} \
63 { folder containing all that you need to run Tcl and Tk. } \
64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \
65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \
}
set result ""
set NL "
"
set tag {level= type=text/plain part=0 sel Charset}
set ix [lsearch -regexp $tag text/enriched]
if {$ix < 0} {
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 |
Tcl/Tk Shop. Check it out!
}
# Check that "break" resets the interpreter's result
test for-4.1 {break must reset the interp result} {
catch {
| | | | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
Tcl/Tk Shop. Check it out!
}
# Check that "break" resets the interpreter's result
test for-4.1 {break must reset the interp result} {
catch {
set z GLOBTESTDIR/dir2/file2.c
if {[string match GLOBTESTDIR/dir2/* $z]} {
break
}
} j
set j
} {}
# Test for incorrect "double evaluation" semantics
test for-5.1 {possible delayed substitution of increment command} {
|
| ︙ | ︙ | |||
773 774 775 776 777 778 779 |
test for-6.16 {Tcl_ForObjCmd: for command result} {
set z for
set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
set a
} {}
test for-6.17 {Tcl_ForObjCmd: for command result} {
list \
| | | | | | | | | | | | | | | | | | | | 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 |
test for-6.16 {Tcl_ForObjCmd: for command result} {
set z for
set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
set a
} {}
test for-6.17 {Tcl_ForObjCmd: for command result} {
list \
[catch {for {break} {1} {} {}} err] $err \
[catch {for {continue} {1} {} {}} err] $err \
[catch {for {} {[break]} {} {}} err] $err \
[catch {for {} {[continue]} {} {}} err] $err \
[catch {for {} {1} {break} {}} err] $err \
[catch {for {} {1} {continue} {}} err] $err \
} [list \
3 {} \
4 {} \
3 {} \
4 {} \
0 {} \
4 {} \
]
test for-6.18 {Tcl_ForObjCmd: for command result} {
proc p6181 {} {
for {break} {1} {} {}
}
proc p6182 {} {
for {continue} {1} {} {}
}
proc p6183 {} {
for {} {[break]} {} {}
}
proc p6184 {} {
for {} {[continue]} {} {}
}
proc p6185 {} {
for {} {1} {break} {}
}
proc p6186 {} {
for {} {1} {continue} {}
}
list \
[catch {p6181} err] $err \
[catch {p6182} err] $err \
[catch {p6183} err] $err \
[catch {p6184} err] $err \
[catch {p6185} err] $err \
[catch {p6186} err] $err
} [list \
1 {invoked "break" outside of a loop} \
1 {invoked "continue" outside of a loop} \
1 {invoked "break" outside of a loop} \
1 {invoked "continue" outside of a loop} \
0 {} \
1 {invoked "continue" outside of a loop} \
|
| ︙ | ︙ |
Changes to tests/foreach.test.
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
append x $a $b $c $d $e
}
set x
} {1111 2222334}
test foreach-2.8 {foreach only sets vars if repeating loop} {
proc foo {} {
| | | | | | | | | | | | | | | | 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 |
foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
append x $a $b $c $d $e
}
set x
} {1111 2222334}
test foreach-2.8 {foreach only sets vars if repeating loop} {
proc foo {} {
set rgb {65535 0 0}
foreach {r g b} [set rgb] {}
return "r=$r, g=$g, b=$b"
}
foo
} {r=65535, g=0, b=0}
test foreach-2.9 {foreach only supports local scalar variables} {
proc foo {} {
set x {}
foreach {a(3)} {1 2 3 4} {lappend x [set {a(3)}]}
set x
}
foo
} {1 2 3 4}
test foreach-3.1 {compiled foreach backward jump works correctly} {
catch {unset x}
proc foo {arrayName} {
upvar 1 $arrayName a
set l {}
foreach member [array names a] {
lappend l [list $member [set a($member)]]
}
return $l
}
array set x {0 zero 1 one 2 two 3 three}
lsort [foo x]
} [lsort {{0 zero} {1 one} {2 two} {3 three}}]
test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} {
catch {unset x}
foreach {12.0} {a b c} {
set x 12.0
set x [expr {$x + 1}]
}
set x
} 13.0
# Check "continue".
test foreach-5.1 {continue tests} {catch continue} 4
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
} -result {2}
# Test for incorrect "double evaluation" semantics
test foreach-7.1 {delayed substitution of body} {
proc foo {} {
set a 0
foreach a [list 1 2 3] "
| | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
} -result {2}
# Test for incorrect "double evaluation" semantics
test foreach-7.1 {delayed substitution of body} {
proc foo {} {
set a 0
foreach a [list 1 2 3] "
set x $a
"
set x
}
foo
} {0}
# Test for [Bug 1189274]; crash on failure
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
list [catch { foo } msg] $msg
} {1 {foreach varlist is empty}}
test foreach-9.2 {line numbers} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
| | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
list [catch { foo } msg] $msg
} {1 {foreach varlist is empty}}
test foreach-9.2 {line numbers} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
foreach x y {*}{
} {return [incr n -[linenumber]]}
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
test foreach-10.1 {foreach: [Bug 1671087]} -setup {
proc demo {} {
|
| ︙ | ︙ |
Changes to tests/format.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
| | < < < | < < < | < < < | < < < | < < < | < < < | < < < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# %z/%t/%p output depends on pointerSize, so some tests are not portable.
testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
# MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain
# particularly in Continuous Integration, and there isn't anything much we can
# do about it.
testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}]
test format-1.1 {integer formatting} {
format "%*d %d %d %d" 6 34 16923 -12 -1
} { 34 16923 -12 -1}
test format-1.2 {integer formatting} {
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} { 6 34 16923 -12 -1 0xe 0xC}
test format-1.3 {integer formatting} {
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} { 6 34 16923 4294967284 -1 0}
test format-1.4 {integer formatting} {
format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
} {6 34 16923 -12 }
test format-1.5 {integer formatting} {
format "%04d %04d %04d %04i" 6 34 16923 -12 -1
} {0006 0034 16923 -012}
test format-1.6 {integer formatting} {
format "%00*d" 6 34
} {000034}
# Printing negative numbers in hex or octal format depends on word
# length, so these tests are not portable.
test format-1.7 {integer formatting} {
format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} { 6 22 421b fffffff4}
test format-1.8 {integer formatting} {
format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
} {0 0x6 0x22 0x421B 0xfffffff4}
test format-1.9 {integer formatting} {
format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
} { 0 0x6 0x22 0x421b 0xfffffff4}
test format-1.10 {integer formatting} {
format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
} {0 0x6 0x22 0x421b 0xfffffff4 }
test format-1.11 {integer formatting} {
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
} {0 0o6 0o42 0o41033 0o37777777764 }
test format-1.12 {integer formatting} {
format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
} {0 0d6 0d34 0d16923 -0d12}
test format-1.14 {integer formatting} {
|
| ︙ | ︙ | |||
378 379 380 381 382 383 384 |
catch {format %d} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.23 {error conditions} {
catch {format "%d %d" 24 xyz} msg
set msg
} {expected integer but got "xyz"}
| < < < < | | < < < < | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
catch {format %d} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.23 {error conditions} {
catch {format "%d %d" 24 xyz} msg
set msg
} {expected integer but got "xyz"}
test format-8.24 {Other formats} -body {
format "%zd %td %d" [expr {2**30}] [expr {2**30}] [expr {2**30}]
} -result {1073741824 1073741824 1073741824}
test format-8.25 {Other formats} -constraints pointerIs64bit -body {
format "%zd %td %lld" [expr {2**33}] [expr {2**33}] [expr {2**33}]
} -result {8589934592 8589934592 8589934592}
test format-8.26 {Other formats} -body {
format "%p %#x" [expr {2**31}] [expr {2**31}]
} -result {0x80000000 0x80000000}
test format-8.27 {Other formats} -constraints pointerIs64bit -body {
format "%p %#llx" [expr {2**33}] [expr {2**33}]
} -result {0x200000000 0x200000000}
test format-8.28 {Internal use of TCL_COMBINE flag should not be visible at script level} {
format %c 0x10000041
} \uFFFD
test format-9.1 {long result} {
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
set a "0123456789"
set b ""
for {set i 0} {$i < 290} {incr i} {
append b $a
}
for {set i 290} {$i < 400} {incr i} {
test format-16.[expr {$i -289}] {testing MAX_FLOAT_SIZE} {
| | | | | | 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 |
set a "0123456789"
set b ""
for {set i 0} {$i < 290} {incr i} {
append b $a
}
for {set i 290} {$i < 400} {incr i} {
test format-16.[expr {$i -289}] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
test format-17.1 {testing %d with wide} {
format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {
format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {
format %ld 42
} 42
test format-17.4 {testing %l with non-integer} {
format %lf 1
} 1.000000
test format-17.5 {testing %llu with positive bignum} -body {
format %llu 0xabcdef0123456789abcdef
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
lappend result [expr {$a == $b}]
set b 0xaaaa
append b aaaa
lappend result [expr {$a == $b}]
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
| | | < | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 |
lappend result [expr {$a == $b}]
set b 0xaaaa
append b aaaa
lappend result [expr {$a == $b}]
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
format %llx 0
} 0
test format-19.3 {Bug 2830354} {
string length [format %340f 0]
} 340
test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} -body {
# in case of overflow into negative, it produces width -2 (and limit exceeded),
# in case of width will be unsigned, it will be outside limit (2GB for 32bit)...
# and it don't throw an error in case the bug is not fixed (and probably no segfault).
format %[expr {0xffffffff - 1}]g 0
} -returnCodes error -result "max size for a Tcl value exceeded"
test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body {
|
| ︙ | ︙ |
Changes to tests/get.test.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
list [catch {testgetint 44 foo} msg] $msg
} {1 {expected integer but got "foo"}}
test get-1.5 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 }} msg] $msg
} {0 60}
test get-1.6 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 x}} msg] $msg
| | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
list [catch {testgetint 44 foo} msg] $msg
} {1 {expected integer but got "foo"}}
test get-1.5 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 }} msg] $msg
} {0 60}
test get-1.6 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 x}} msg] $msg
} {1 {expected integer but got a list}}
test get-1.7 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} {
testgetint 18446744073709551614
} {-2}
test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} {
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"]
foreach num $numbers {
lappend result [catch {format %ld $num} msg] $msg
}
set result
| | | | | 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 |
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"]
foreach num $numbers {
lappend result [catch {format %ld $num} msg] $msg
}
set result
} {0 1 0 1 1 {expected integer but got "++1"} 1 {expected integer but got "+-1"} 1 {expected integer but got "-+1"} 0 -1 1 {expected integer but got "--1"} 1 {expected integer but got a list} 0 12345678987654321 1 {expected integer but got "++12345678987654321"}}
test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} {
set result ""
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
foreach num $numbers {
lappend result [catch {format %g $num} msg] $msg
}
set result
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got a list}}
# Bug 7114ac6141
test get-3.3 {tcl_GetInt with iffy numbers} testgetint {
lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} {
catch {testgetint 44 $x} x
set x
}
} {44 44 44 44 54 54 52 46}
test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10" "2_0.3_4e+1_5" _1.0e+2 1_.0e+2 1._0e+2 1.0_e+2 1.0e_+2 1.0e+_2 1.0e+2_ 1_1.0e+0_2 2__2.0e+2__2 54321________} {
catch {testdoubleobj set 1 $x} x
set x
}
} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got a list} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}}
test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint {
lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x0_a " 0b1111_1111 " 0_07 " " 0o1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 0x_b 0o_2_0 0o2__3_4} {
catch {testgetint $x} x
set x
}
} {0 10 2 33 1423324 10 255 7 8 {expected integer but got " 0b_1_0 "} {expected integer but got " 0_b1_0 "} {expected integer but got "_33"} {expected integer but got "42_"} {expected integer but got "0_x15"} {expected integer but got "0_o17"} {expected integer but got "0_d19"} {expected integer but got "0x_b"} {expected integer but got "0o_2_0"} 156}
|
| ︙ | ︙ |
Changes to tests/http.test.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 |
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} {
| | | | | | 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 |
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
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
# 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]} {
| | | 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 |
# 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]
|
| ︙ | ︙ |
Changes to tests/http11.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
package require http 2.10
#http::register http 80 ::socket
# start the server
variable httpd_output
proc create_httpd {} {
proc httpd_read {chan} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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} {
#puts stderr "read '$line'"
set httpd_output $line
}
if {[eof $chan]} {
puts stderr "eof from httpd"
fileevent $chan readable {}
close $chan
}
}
variable httpd_output
set httpd_script [file join [pwd] [file dirname [info script]] httpd11.tcl]
set httpd [open "|[list [interpreter] -encoding utf-8 $httpd_script]" r+]
fconfigure $httpd -buffering line -blocking 0
fileevent $httpd readable [list httpd_read $httpd]
vwait httpd_output
variable httpd_port [lindex $httpd_output 2]
return $httpd
}
proc halt_httpd {} {
variable httpd_output
variable httpd
if {[info exists httpd]} {
puts $httpd "quit"
vwait httpd_output
close $httpd
}
unset -nocomplain httpd_output httpd
}
proc meta {tok {key ""}} {
if {$key eq ""} {
return [http::meta $tok]
} else {
return [http::metaValue $tok $key]
}
}
proc state {tok {key ""}} {
upvar 1 $tok state
if {$key ne ""} {
if {[array names state -exact $key] ne {}} {
return $state($key)
} else {
return ""
}
}
set res [array get state]
dict set res body <elided>
return $res
}
proc check_crc {tok args} {
set crc [meta $tok x-crc32]
set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}]
set chk [format %x [zlib crc32 $data]]
if {$crc ne $chk} {
return "crc32 mismatch: $crc ne $chk"
}
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
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
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 \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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}
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
}
test http11-2.0.$ThreadLevel "-channel" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}
test http11-2.0.$ThreadLevel "-channel" -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]
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.
# The pass/fail depended on file size.
test http11-2.1.1.$ThreadLevel "-channel, encoding gzip" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
set fileName largedoc.html
} -body {
set tok [http::geturl http://localhost:$httpd_port/$fileName \
-timeout 5000 -channel $chan -headers {accept-encoding gzip}]
http::wait $tok
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.
# Bug [a13b9d0ce1].
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 compress}]
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]
set chan [open [makeFile {} testfile.tmp] wb+]
set logdata ""
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-timeout 5000 -channel $chan \
-headers {accept-encoding identity} \
-progress [namespace code [list progress logdata]]]
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 {[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 {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
set logdata ""
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-timeout 5000 -channel $chan \
-headers {accept-encoding identity} \
-progress [namespace code [list progressPause logdata]]]
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 {[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
# compliant "decompress" is tried, not the non-compliant "inflate" of
# the MS browser implementation.
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&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]\
[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.
# Bug [a13b9d0ce1].
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 compress}]
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 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}
|
| ︙ | ︙ | |||
788 789 790 791 792 793 794 |
}
test http11-3.0.$ThreadLevel "-handler,close,identity" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
| | | | | | | | | | | | | | | | | | | | | 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 |
}
test http11-3.0.$ThreadLevel "-handler,close,identity" -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 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
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
# open. In HTTP/1.0 this is not the case, and this is a test that
# the Tcl client assumes "Connection: close" by default in HTTP/1.0.
test http11-3.4.$ThreadLevel "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# open. In HTTP/1.0 this is not the case, and this is a test that
# the Tcl client assumes "Connection: close" by default in HTTP/1.0.
test http11-3.4.$ThreadLevel "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \
-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}
|
| ︙ | ︙ |
Changes to tests/httpPipeline.test.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 |
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} {
| | | | | | 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 |
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
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
return -code error {no matching script}
}
}
if {$ca < 3} {
# Not Keep-Alive.
| | | | | | | | | | | | | | | | | | 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 |
return -code error {no matching script}
}
}
if {$ca < 3} {
# Not Keep-Alive.
set result "Passed all sanity checks."
} elseif {$ca == 3} {
# Keep-Alive, not pipelined.
set result {}
append result "Passed all sanity checks.\n"
append result "Have overlaps including response body:\n"
} else {
# Keep-Alive, pipelined: ($ca == 4)
set result {}
append result "Passed all sanity checks.\n"
append result "Overlap-free without response body:\n"
append result "$resShort"
}
# - The special case of test *.18*-testEof needs test results to be
# individually written.
# - These test -repost 0 when there is a POST to apply it to, and the server
# timeout has not been detected.
if {($cb == 18) && ($te == 1)} {
if {$ca < 3} {
# Not Keep-Alive.
set result "Passed all sanity checks."
} elseif {$ca == 3 && $delay == 0} {
# Keep-Alive, not pipelined.
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|Wrong sequence for token ::http::3 - {A X X}
|- and error(s) X
|Wrong sequence for token ::http::4 - {A X X X}
|- and error(s) X
|
|Have overlaps including response body:
|
}]
} elseif {$ca == 3} {
# Keep-Alive, not pipelined.
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|
|Have overlaps including response body:
|
}]
} elseif {$delay == 0} {
# Keep-Alive, pipelined: ($ca == 4)
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|Wrong sequence for token ::http::3 - {A X X}
|- and error(s) X
|Wrong sequence for token ::http::4 - {A X X X}
|- and error(s) X
|
|Overlap-free without response body:
|
}]
} else {
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|
|Overlap-free without response body:
|
}]
}
}
return [list "$start$middle$end" $result]
}
# ------------------------------------------------------------------------------
# Proc MakeMessage
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
set notPiped {}
set notIncluded {}
# --------------------------------------------------------------------------
# Custom code for specific tests
# --------------------------------------------------------------------------
if {$header < 3} {
| | | | | | | | | | | | | | | | | | | | | | 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 |
set notPiped {}
set notIncluded {}
# --------------------------------------------------------------------------
# Custom code for specific tests
# --------------------------------------------------------------------------
if {$header < 3} {
set skipOverlaps 1
for {set i 1} {$i <= $num} {incr i} {
lappend notPiped $i
}
} elseif {$header > 2 && $footer == 18 && $te == 1} {
set skipOverlaps 1
if {$delay == 0} {
# Transaction 1 is conventional.
# Check that transactions 2,3,4 are cancelled.
set notPiped {1}
set notIncluded $notPiped
} else {
# Transaction 1 is conventional.
# Check that transaction 2 is cancelled.
# The timing of transactions 3 and 4 is uncertain.
set notPiped {1 3 4}
set notIncluded $notPiped
}
} elseif {$footer in {20 22 23 24 25}} {
# Transaction 2 uses its own socket.
set notPiped 2
set notIncluded $notPiped
} else {
}
# --------------------------------------------------------------------------
# End of custom code for specific tests
# --------------------------------------------------------------------------
set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped]
lassign $Results msg cleanE cleanF dirtyE dirtyF
if {$msg eq {}} {
set msg "Passed all sanity checks."
} else {
set msg "Problems with sanity checks:\n$msg"
}
if 0 {
puts $msg
puts "Overlap-free including response body:\n$cleanF"
puts "Have overlaps including response body:\n$dirtyF"
puts "Overlap-free without response body:\n$cleanE"
puts "Have overlaps without response body:\n$dirtyE"
}
if {$header < 3} {
# No ordering, just check that transactions all finish
set result $msg
} elseif {$header == 3} {
# Not pipelined - check overlaps with response body.
set result "$msg\nHave overlaps including response body:\n$dirtyF"
} else {
# Pipelined - check overlaps without response body. Check that the
# first request, the first requests after replay, and POSTs are clean.
set result "$msg\nOverlap-free without response body:\n$cleanE"
}
set ::nTokens $num
return $result
}
# ------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 |
# connection ater the current request.
# - Any other variables should be ignored.
# ------------------------------------------------------------------------------
namespace eval ::httpTestScript {
variable URL
array set URL {
| | | | | 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 |
# connection ater the current request.
# - Any other variables should be ignored.
# ------------------------------------------------------------------------------
namespace eval ::httpTestScript {
variable URL
array set URL {
a http://test-tcl-http.kerlin.org/index.html?page=privacy
b http://test-tcl-http.kerlin.org/index.html?page=conditions
c http://test-tcl-http.kerlin.org/index.html?page=welcome
}
}
# ------------------------------------------------------------------------------
# (5) Define the tests
# ------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
755 756 757 758 759 760 761 |
# ------------------------------------------------------------------------------
proc SetTestEof {test} {
set body [info body ::http::KeepSocket]
set subs " set TEST_EOF $test"
set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody]
if {$count != 1} {
| | | | | | | | 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 |
# ------------------------------------------------------------------------------
proc SetTestEof {test} {
set body [info body ::http::KeepSocket]
set subs " set TEST_EOF $test"
set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody]
if {$count != 1} {
return -code error {proc ::http::KeepSocket has unexpected form}
}
proc ::http::KeepSocket {token} $newBody
return
}
for {set header 1} {$header <= 4} {incr header} {
if {$header == 4} {
setHttpTestOptions -dotted 1
set match glob
} else {
setHttpTestOptions -dotted 0
set match exact
}
if {$header == 2} {
set cons0 {serverNeeded duplicate}
} else {
set cons0 serverNeeded
}
for {set footer 1} {$footer <= 25} {incr footer} {
foreach {delay label} {
0 a
1 b
2 c
3 d
5 e
8 f
12 g
100 h
500 i
2000 j
} {
foreach te {0 1} {
if {$te} {
set tag testEof
} else {
set tag normal
}
set suffix {}
set cons $cons0
# ------------------------------------------------------------------
# Custom code for individual tests
# ------------------------------------------------------------------
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 | # Test use WAIT and depend on server timeout before this time. lappend cons timeout1s } # ------------------------------------------------------------------ # End of custom code. # ------------------------------------------------------------------ | | | | | | | | 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 |
# Test use WAIT and depend on server timeout before this time.
lappend cons timeout1s
}
# ------------------------------------------------------------------
# End of custom code.
# ------------------------------------------------------------------
set name "pipeline test header $header footer $footer delay $delay $tag$suffix"
# Here's the test:
test httpPipeline-${header}.${footer}${label}-${tag}-$ThreadLevel $name \
-constraints $cons \
-setup [string map [list TE $te] {
# Restore default values for tests:
http::config -pipeline 1 -postfresh 0 -repost 1
http::init
set http::http(uid) 0
SetTestEof {TE}
}] -body [list RunTest $header $footer $delay $te] -cleanup {
# Restore default values for tests:
http::config -pipeline 1 -postfresh 0 -repost 1
cleanupHttpTestScript
SetTestEof 0
cleanupHttpTest
|
| ︙ | ︙ |
Changes to tests/httpProxy.test.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
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} {
| | | | | | | | | | | 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 |
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
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
#
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)} {
| | | | | | | | | | 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 |
#
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.
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 |
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] --\
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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 {
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
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] --\
| | | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
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 {}
}
|
| ︙ | ︙ | |||
493 494 495 496 497 498 499 |
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] --\
| | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
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 {}
}
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 |
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] --\
| | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
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 {}
}
|
| ︙ | ︙ | |||
557 558 559 560 561 562 563 |
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] --\
| | | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 |
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 {}
}
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 |
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] --\
| | | | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
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 {}
}
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 |
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] --\
| | | | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
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 {}
}
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 |
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] --\
| | | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
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 {}
}
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
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] --\
| | | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 |
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 {}
}
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
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] --\
| | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 |
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 {}
}
|
| ︙ | ︙ | |||
754 755 756 757 758 759 760 |
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] --\
| | | | | | | | | | | | | | | | 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 |
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 {
|
| ︙ | ︙ | |||
891 892 893 894 895 896 897 |
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] --\
| | | | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
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 {}
}
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
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] --\
| | | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 |
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 {}
}
|
| ︙ | ︙ | |||
951 952 953 954 955 956 957 |
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] --\
| | | | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 |
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 {}
}
|
| ︙ | ︙ | |||
986 987 988 989 990 991 992 |
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] --\
| | | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
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 {}
}
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
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] --\
| | | | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 |
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 {}
}
|
| ︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 |
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] --\
| | | | | | | | | | | | | | | | 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 |
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 {
|
| ︙ | ︙ | |||
1191 1192 1193 1194 1195 1196 1197 |
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] --\
| | | | 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 |
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 {}
}
|
| ︙ | ︙ | |||
1226 1227 1228 1229 1230 1231 1232 |
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] --\
| | | | 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 |
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 {}
}
|
| ︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 |
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] --\
| | | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
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 {}
}
|
| ︙ | ︙ | |||
1294 1295 1296 1297 1298 1299 1300 |
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] --\
| | | | 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
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 {}
}
|
| ︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 |
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] --\
| | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 |
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 {}
}
|
| ︙ | ︙ | |||
1354 1355 1356 1357 1358 1359 1360 |
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] --\
| | | | 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 |
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 {}
}
|
| ︙ | ︙ |
Changes to tests/httpTest.tcl.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"}
}
namespace eval ::httpTest {
variable testResults {}
variable testOptions
array set testOptions {
| | | | | | | | | | | | | | | | | 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 |
# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"}
}
namespace eval ::httpTest {
variable testResults {}
variable testOptions
array set testOptions {
-verbose 0
-dotted 1
}
# -verbose - 0 quiet 1 write to stdout 2 write more
# -dotted - (boolean) use dots for absences in lists of transactions
}
proc httpTest::Puts {txt} {
variable testOptions
if {$testOptions(-verbose) > 0} {
puts stdout $txt
flush stdout
}
return
}
# http::Log
#
# A special-purpose logger used for running tests.
# - Processes Log calls that have "^" in their arguments, and records them in
# variable ::httpTest::testResults.
# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0).
# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
proc http::Log {args} {
variable TestStartTimeInMs
set time [expr {[clock milliseconds] - $TestStartTimeInMs}]
set txt [list $time {*}$args]
if {[string first ^ $txt] >= 0} {
::httpTest::LogRecord $txt
::httpTest::Puts $txt
} elseif {$::httpTest::testOptions(-verbose) > 1} {
::httpTest::Puts $txt
}
return
}
# The http::Log routine above needs the variable ::httpTest::testOptions
# Set up to destroy it when that variable goes away.
trace add variable ::httpTest::testOptions unset {apply {args {
proc ::http::Log args {}
}}}
# Called by http::Log (the "testing" version) to record logs for later analysis.
proc httpTest::LogRecord {txt} {
variable testResults
set pos [string first ^ $txt]
set len [string length $txt]
if {$pos > $len - 3} {
puts stdout "Logging Error: $txt"
puts stdout "Fix this call to Log in http-*.tm so it has ^ then\
a letter then a numeral."
flush stdout
} elseif {$pos < 0} {
# Called by mistake.
} else {
set letter [string index $txt [incr pos]]
set number [string index $txt [incr pos]]
# Max 9 requests!
lappend testResults [list $letter $number]
}
return
}
# ------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} {
variable testOptions
# Check whether transactions overlap:
set clean {}
set dirty {}
for {set i 1} {$i <= $n} {incr i} {
| | | | | | | | | | | | | 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 |
proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} {
variable testOptions
# Check whether transactions overlap:
set clean {}
set dirty {}
for {set i 1} {$i <= $n} {incr i} {
if {$i in $badTrans} {
continue
}
set myStart [lsearch -exact $someResults [list B $i]]
set myEnd [lsearch -exact $someResults [list $term $i]]
if {($myStart < 0 || $myEnd < 0)} {
set res "Cannot find positions of transaction $i"
append msg $res \n
Puts $res
}
set overlaps {}
for {set j $myStart} {$j <= $myEnd} {incr j} {
lassign [lindex $someResults $j] letter number
if {$number != $i && $letter ne "A" && $number ni $notPiped} {
lappend overlaps $number
}
}
if {[llength $overlaps] == 0} {
set res "Transaction $i has no overlaps"
Puts $res
lappend clean $i
if {$testOptions(-dotted)} {
# N.B. results from different segments are concatenated.
lappend dirty .
} else {
}
} else {
set res "Transaction $i overlaps with [join $overlaps { }]"
Puts $res
lappend dirty $i
if {$testOptions(-dotted)} {
# N.B. results from different segments are concatenated.
lappend clean .
} else {
}
}
}
return [list $msg $clean $dirty]
}
# httpTest::PipelineNext --
#
# Test whether prevPair, pair are valid as consecutive elements of a pipelined
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
# any - (boolean) iff true, accept any increasing sequence of integers.
# If false, integers must increase by 1.
#
# Return value - boolean, true iff the two pairs are valid consecutive elements.
proc httpTest::PipelineNext {Start End prevPair pair any} {
if {$prevPair eq {}} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# any - (boolean) iff true, accept any increasing sequence of integers.
# If false, integers must increase by 1.
#
# Return value - boolean, true iff the two pairs are valid consecutive elements.
proc httpTest::PipelineNext {Start End prevPair pair any} {
if {$prevPair eq {}} {
return 1
}
lassign $prevPair letter number
lassign $pair newLetter newNumber
if {$letter eq $Start} {
return [expr {($newLetter eq $End) && ($newNumber == $number)}]
} elseif {$any} {
set nxt [list $Start [expr {$number + 1}]]
return [expr {($newLetter eq $Start) && ($newNumber > $number)}]
} else {
set nxt [list $Start [expr {$number + 1}]]
return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}]
}
}
# httpTest::TestPipeline --
#
# Given a sequence of "pair" elements, check that the elements whose string is
# $Start or $End form a valid pipeline. Ignore other elements.
#
# Return value: {} if valid pipeline, otherwise a non-empty error message.
proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} {
set sequence {}
set prevPair {}
set ok 1
set any [llength $badTrans]
foreach pair $someResults {
lassign $pair letter number
if {($letter in [list $Start $End]) && ($number ni $badTrans)} {
lappend sequence $pair
if {![PipelineNext $Start $End $prevPair $pair $any]} {
set ok 0
break
}
set prevPair $pair
}
}
if {!$ok} {
set res "$desc are not pipelined: {$sequence}"
append msg $res \n
Puts $res
}
return $msg
}
# httpTest::TestSequence --
#
# Examine each transaction from 1 to $n, ignoring any that are listed
# in $badTrans.
# Check that each transaction has elements A to F, in alphabetical order.
proc httpTest::TestSequence {someResults n msg badTrans} {
variable testOptions
for {set i 1} {$i <= $n} {incr i} {
if {$i in $badTrans} {
continue
}
set sequence {}
foreach pair $someResults {
lassign $pair letter number
if {$number == $i} {
lappend sequence $letter
}
}
if {$sequence eq {A B C D E F}} {
} else {
set res "Wrong sequence for token ::http::$i - {$sequence}"
append msg $res \n
Puts $res
if {"X" in $sequence} {
set res "- and error(s) X"
append msg $res \n
Puts $res
}
if {"Y" in $sequence} {
set res "- and warnings(s) Y"
append msg $res \n
Puts $res
}
}
}
return $msg
}
#
# Arguments:
# someResults - list of elements, each a list of a letter and a number
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 |
# MostAnalysis for processing.
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
variable testOptions
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
if {$nextRetry < 0} {
| | | | | | | | | 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 |
# MostAnalysis for processing.
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
variable testOptions
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
if {$nextRetry < 0} {
return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped]
}
set badTrans $notIncluded
set tryCount 0
set try $nextRetry
incr tryCount
lassign [lindex $someResults $try] letter number
Puts "Processing retry [lindex $someResults $try]"
set beforeTry [lrange $someResults 0 $try-1]
Puts [join $beforeTry \n]
set afterTry [lrange $someResults $try+1 end]
set dummyTry {}
for {set i 1} {$i <= $n} {incr i} {
set first [lsearch -exact $beforeTry [list A $i]]
set last [lsearch -exact $beforeTry [list F $i]]
if {$first < 0} {
set res "Transaction $i was not started in connection number $tryCount"
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
# append msg $res \n
Puts $res
if {$i ni $badTrans} {
lappend badTrans $i
} else {
}
} elseif {$last < 0} {
set res "Transaction $i was started but unfinished in connection number $tryCount"
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
# append msg $res \n
Puts $res
lappend badTrans $i
lappend dummyTry [list A $i]
} else {
set res "Transaction $i was started and finished in connection number $tryCount"
# So include it in the call below of MostAnalysis.
# So lappend it to notIncluded and don't include it in the recursive call of
# ProcessRetries which handles the later connections.
# append msg $res \n
Puts $res
lappend notIncluded $i
}
}
# Analyse the part of the results before the first replay:
set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped]
lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1
# Pass the rest of the results to be processed recursively.
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 |
set testResults {}
return
}
proc httpTest::setHttpTestOptions {key args} {
variable testOptions
if {$key ni {-dotted -verbose}} {
| | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
set testResults {}
return
}
proc httpTest::setHttpTestOptions {key args} {
variable testOptions
if {$key ni {-dotted -verbose}} {
return -code error {valid options are -dotted, -verbose}
}
set testOptions($key) {*}$args
}
namespace eval httpTest {
namespace export cleanupHttpTest logAnalyse setHttpTestOptions
}
|
Changes to tests/httpTestScript.tcl.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
variable CountFinishedSoFar
variable RequestList
variable RequestsMade
variable ExtraTime
variable ActualKeepAlive
if {[info exists StartDone] && ($StartDone == 1)} {
| | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
variable CountFinishedSoFar
variable RequestList
variable RequestsMade
variable ExtraTime
variable ActualKeepAlive
if {[info exists StartDone] && ($StartDone == 1)} {
set msg {START has been called twice without an intervening STOP}
return -code error $msg
}
set StartDone 1
set StopDone 0
set TimeOutDone 0
set CountFinishedSoFar 0
set CountRequestedSoFar 0
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
variable RequestsWhenStopped
variable TimeOutCode
variable StartDone
variable StopDone
variable RequestsMade
if {$StopDone} {
| | | | | | | | | | | | | | | | | | | | | | 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 |
variable RequestsWhenStopped
variable TimeOutCode
variable StartDone
variable StopDone
variable RequestsMade
if {$StopDone} {
# Don't do anything on a second call.
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
set StopDone 1
set StartDone 0
set RequestsWhenStopped $CountRequestedSoFar
unset -nocomplain StartDone
if {$CountFinishedSoFar == $RequestsWhenStopped} {
if {[info exists TimeOutCode]} {
after cancel $TimeOutCode
}
set ::httpTestScript::FOREVER 0
}
return
}
# httpTestScript::DELAY --
# If there are no WAIT commands, this sets the delay in ms between subsequent
# calls to http::geturl. Default 500ms.
proc httpTestScript::DELAY {t} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
variable Delay
set Delay $t
return
}
# httpTestScript::KEEPALIVE --
# Set the value passed to http::geturl for the -keepalive option. Default 1.
proc httpTestScript::KEEPALIVE {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
variable KeepAlive
set KeepAlive $b
return
}
# httpTestScript::WAIT --
# Pause for a time in ms before processing any more commands.
proc httpTestScript::WAIT {t} {
variable StartDone
variable StopDone
variable ExtraTime
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
if {(![string is integer -strict $t]) || $t < 0} {
return -code error {argument to WAIT must be a non-negative integer}
}
incr ExtraTime $t
return
}
# httpTestScript::PIPELINE --
# Pass a value to http::config -pipeline.
proc httpTestScript::PIPELINE {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
::http::config -pipeline $b
##::http::Log http(-pipeline) is now [::http::config -pipeline]
return
}
# httpTestScript::POSTFRESH --
# Pass a value to http::config -postfresh.
proc httpTestScript::POSTFRESH {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
::http::config -postfresh $b
##::http::Log http(-postfresh) is now [::http::config -postfresh]
return
}
# httpTestScript::REPOST --
# Pass a value to http::config -repost.
proc httpTestScript::REPOST {b} {
variable StartDone
variable StopDone
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
::http::config -repost $b
##::http::Log http(-repost) is now [::http::config -repost]
return
}
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 |
variable Delay
variable ExtraTime
variable StartDone
variable StopDone
variable KeepAlive
if {$StopDone} {
| | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
variable Delay
variable ExtraTime
variable StartDone
variable StopDone
variable KeepAlive
if {$StopDone} {
return
}
if {![info exists StartDone]} {
return -code error {initialise the script by calling command START}
}
incr CountRequestedSoFar
set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}]
# Could pass values of -pipeline, -postfresh, -repost if it were
# useful to change these mid-script.
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 |
set absUrl $URL($uriCode)
if {$query eq {}} {
if {$args ne {}} {
append absUrl & [join $args &]
}
set queryArgs {}
} elseif {$validate} {
| | | | | | | | | | | | | 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 |
set absUrl $URL($uriCode)
if {$query eq {}} {
if {$args ne {}} {
append absUrl & [join $args &]
}
set queryArgs {}
} elseif {$validate} {
return -code error {cannot have both -validate (HEAD) and -query (POST)}
} else {
set queryArgs [list -query [join $args &]]
}
if {[catch {
::http::geturl $absUrl \
-validate $validate \
-timeout 10000 \
{*}$queryArgs \
-keepalive $keepAlive \
-command ::httpTestScript::WhenFinished
} token]} {
set msg $token
catch {puts stdout "Error: $msg"}
return
} else {
# Request will begin.
}
return
}
proc httpTestScript::TimeOutNow {} {
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
}
} err]} {
::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken
}
incr CountFinishedSoFar
if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} {
| | | | | | | | | | 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 |
}
} err]} {
::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken
}
incr CountFinishedSoFar
if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} {
if {[info exists TimeOutCode]} {
after cancel $TimeOutCode
}
if {$RequestsMade ne $RequestList && $ActualKeepAlive} {
::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken
}
set ::httpTestScript::FOREVER 0
}
return
}
proc httpTestScript::runHttpTestScript {scr} {
variable TimeOutDone
variable RequestsWhenStopped
after idle [list namespace eval ::httpTestScript $scr]
vwait ::httpTestScript::FOREVER
# N.B. does not automatically execute in this namespace, unlike some other events.
# Release when all requests have been served or have timed out.
if {$TimeOutDone} {
return -code error {test script timed out}
}
return $RequestsWhenStopped
}
proc httpTestScript::cleanupHttpTestScript {} {
variable TimeOutDone
variable RequestsWhenStopped
if {![info exists RequestsWhenStopped]} {
return -code error {Cleanup Failed: RequestsWhenStopped is undefined}
}
for {set i 1} {$i <= $RequestsWhenStopped} {incr i} {
http::cleanup ::http::$i
}
return
}
|
Changes to tests/httpd.
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
}
return
} elseif {$data(state) == "mime"} {
# Read the HTTP headers
set readCount [gets $sock line]
| | | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
}
return
} elseif {$data(state) == "mime"} {
# Read the HTTP headers
set readCount [gets $sock line]
if {[regexp {^([^:]+):(.*)$} $line -> key val]} {
lappend data(meta) $key [string trim $val]
}
} elseif {$data(state) == "query"} {
# Read the query data
if {![info exists data(length_orig)]} {
set data(length_orig) $data(length)
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
# Catch errors from premature client closes
catch {
if {$data(proto) == "HEAD"} {
puts $sock "HTTP/1.0 200 OK"
} else {
| | | | | | | | | | | 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 |
# Catch errors from premature client closes
catch {
if {$data(proto) == "HEAD"} {
puts $sock "HTTP/1.0 200 OK"
} else {
# Split the response to test for [Bug 26245326]
puts -nonewline $sock "HT"
flush $sock
puts $sock "TP/1.0 200 Data follows"
}
puts $sock "Date: [clock format [clock seconds] \
-format {%a, %d %b %Y %H:%M:%S %Z}]"
puts $sock "Content-Type: $type"
puts $sock "Content-Length: [string length $html]"
foreach {key val} $data(meta) {
if {[string match "X-*" $key]} {
puts $sock "$key: $val"
}
}
puts $sock ""
flush $sock
if {$data(proto) != "HEAD"} {
fconfigure $sock -translation binary
puts -nonewline $sock $html
}
}
httpd_log $sock Done ""
httpdSockDone $sock
}
|
Changes to tests/httpd11.tcl.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl
proc ::tcl::dict::get? {dict key} {
if {[dict exists $dict $key]} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl
proc ::tcl::dict::get? {dict key} {
if {[dict exists $dict $key]} {
return [dict get $dict $key]
}
return
}
namespace ensemble configure dict \
-map [linsert [namespace ensemble configure dict -map] end get? ::tcl::dict::get?]
proc make-chunk-generator {data {size 4096}} {
variable _chunk_gen_uid
if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0}
set lambda {{data size} {
set pos 0
yield
while {1} {
set payload [string range $data $pos [expr {$pos + $size - 1}]]
incr pos $size
set chunk [format %x [string length $payload]]\r\n$payload\r\n
yield $chunk
if {![string length $payload]} {return}
}
}}
set name chunker[incr _chunk_gen_uid]
coroutine $name ::apply $lambda $data $size
return $name
}
proc get-chunks {data {compression gzip}} {
switch -exact -- $compression {
gzip { set data [zlib gzip $data] }
deflate { set data [zlib deflate $data] }
compress { set data [zlib compress $data] }
}
set data ""
set chunker [make-chunk-generator $data 671]
while {[string length [set chunk [$chunker]]]} {
append data $chunk
}
return $data
}
proc blow-chunks {data {ochan stdout} {compression gzip}} {
switch -exact -- $compression {
gzip { set data [zlib gzip $data] }
deflate { set data [zlib deflate $data] }
compress { set data [zlib compress $data] }
}
set chunker [make-chunk-generator $data 671]
while {[string length [set chunk [$chunker]]]} {
puts -nonewline $ochan $chunk
}
return
}
proc mime-type {filename} {
switch -exact -- [file extension $filename] {
.htm - .html { return {text text/html}}
.png { return {binary image/png} }
.jpg { return {binary image/jpeg} }
.gif { return {binary image/gif} }
.css { return {text text/css} }
.xml { return {text text/xml} }
.xhtml {return {text application/xml+html} }
.svg { return {text image/svg+xml} }
.txt - .tcl - .c - .h { return {text text/plain}}
}
return {binary text/plain}
}
proc Puts {chan s} {puts $chan $s; puts $s}
proc Service {chan addr port} {
chan event $chan readable [info coroutine]
while {1} {
set meta {}
chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
chan configure $chan -blocking 0
yield
while {[gets $chan line] < 0} {
if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
yield
}
if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
foreach {req url protocol} {GET {} HTTP/1.1} break
regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol
puts $line
while {[gets $chan line] > 0} {
if {[regexp {^([^:]+):(.*)$} $line -> key val]} {
puts [list $key [string trim $val]]
lappend meta [string tolower $key] [string trim $val]
}
yield
}
set encoding identity
set transfer ""
set close 1
set type text/html
set code "404 Not Found"
set data "<html><head><title>Error 404</title></head>"
append data "<body><h1>Not Found</h1><p>Try again.</p></body></html>"
if {[scan $url {%[^?]?%s} path query] < 2} {
set query ""
}
switch -exact -- $req {
GET - HEAD {
}
POST {
# Read the query.
set qlen [dict get? $meta content-length]
if {[string is integer -strict $qlen]} {
chan configure $chan -buffering none -translation binary
while {[string length $query] < $qlen} {
append query [read $chan $qlen]
if {[string length $query] < $qlen} {yield}
}
# Check for excess query bytes [Bug 2715421]
if {[dict get? $meta x-check-query] eq "yes"} {
chan configure $chan -blocking 0
append query [read $chan]
}
}
}
default {
# invalid request error 5??
}
}
if {$query ne ""} {puts $query}
set path [string trimleft $path /]
set path [file join [pwd] $path]
if {[file exists $path] && [file isfile $path]} {
foreach {what type} [mime-type $path] break
set f [open $path r]
if {$what eq "binary"} {
chan configure $f -translation binary
} else {
chan configure $f -encoding utf-8
}
set data [read $f]
close $f
set code "200 OK"
set close [expr {[dict get? $meta connection] eq "close"}]
}
if {$protocol eq "HTTP/1.1"} {
foreach enc [split [dict get? $meta accept-encoding] ,] {
set enc [string trim $enc]
# The current implementation of "compress" appears to be
# incorrect (bug [a13b9d0ce1]). Keep it here for
# experimentation only. The tests that use it have the
# constraint "badCompress". The client code in http has
# been removed, but can be restored from comments if
# experimentation is desired.
if {$enc in {deflate gzip compress}} {
set encoding $enc
break
}
}
set transfer chunked
} else {
set close 1
}
set nosendclose 0
set msdeflate 0
foreach pair [split $query &] {
if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
switch -exact -- $key {
nosendclose {set nosendclose 1}
close {set close 1 ; set transfer 0}
transfer {set transfer $val}
content-type {set type $val}
msdeflate {set msdeflate $val}
}
}
if {$protocol eq "HTTP/1.1"} {
set nosendclose 0
}
chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
Puts $chan "$protocol $code"
Puts $chan "content-type: $type"
Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]]
if {$req eq "POST"} {
Puts $chan [format "x-query-length: %d" [string length $query]]
}
if {$close && (!$nosendclose)} {
Puts $chan "connection: close"
}
Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
if {$encoding eq "identity" && (!$nosendclose)} {
Puts $chan "content-length: [string length $data]"
} elseif {$encoding eq "identity"} {
# This is a blatant attempt to confuse the client by sending neither
# "Connection: close" nor "Content-Length" when in non-chunked mode.
# See test http11-3.4.
} else {
Puts $chan "content-encoding: $encoding"
}
if {$transfer eq "chunked"} {
Puts $chan "transfer-encoding: chunked"
}
puts $chan ""
flush $chan
chan configure $chan -buffering full -translation binary
if {$encoding eq {deflate}} {
# When http.tcl uses the correct decoder (bug [a13b9d0ce1]) for
# "accept-encoding deflate", i.e. "zlib decompress", this choice of
# encoding2 allows the tests to pass. It appears to do "deflate"
# correctly, but this has not been verified with a non-Tcl client.
set encoding2 compress
} else {
set encoding2 $encoding
}
if {$transfer eq "chunked"} {
blow-chunks $data $chan $encoding2
} elseif {$encoding2 ne "identity" && $msdeflate eq {1}} {
puts -nonewline $chan [string range [zlib $encoding2 $data] 2 end-4]
# Used in some tests of "deflate" to produce the non-RFC-compliant
# Microsoft version of "deflate".
} elseif {$encoding2 ne "identity"} {
puts -nonewline $chan [zlib $encoding2 $data]
} else {
puts -nonewline $chan $data
}
if {$close} {
chan event $chan readable {}
close $chan
puts "close $chan"
return
} else {
flush $chan
}
puts "pipeline $chan"
}
}
proc Accept {chan addr port} {
coroutine client$chan Service $chan $addr $port
return
}
proc Control {chan} {
if {[gets $chan line] >= 0} {
if {[string trim $line] eq "quit"} {
set ::forever 1
}
}
if {[eof $chan]} {
chan event $chan readable {}
}
}
proc Main {{port 0}} {
set server [socket -server Accept -myaddr localhost $port]
puts [chan configure $server -sockname]
flush stdout
|
| ︙ | ︙ |
Added tests/icu.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# Tests for tcl::unsupported::icu
# Contains basic sanity checks only! Commands are not intended for
# production use.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
# Force late loading of ICU if present
catch {::tcl::unsupported::icu}
testConstraint icu [llength [info commands ::tcl::unsupported::icu::detect]]
namespace eval icu {
namespace path {::tcl::unsupported ::tcl::mathop}
test icu-detect-0 {Return list of ICU encodings} -constraints icu -body {
set encoders [icu detect]
list [in UTF-8 $encoders] [in ISO-8859-1 $encoders]
} -result {1 1}
test icu-detect-1 {Guess encoding} -constraints icu -body {
icu detect [readFile [info script]]
} -result ISO-8859-1
test icu-detect-2 {Get all possible encodings} -constraints icu -body {
set encodings [icu detect [readFile [info script]] -all]
list [in UTF-8 $encodings] [in ISO-8859-1 $encodings]
} -result {1 1}
test icu-detect-3 {error case} -constraints icu -returnCodes error -body {
icu detect gorp gorp gorp
} -result {wrong # args: should be "icu detect ?bytes ?-all??"}
test icu-tclToIcu-0 {Map Tcl encoding} -constraints icu -body {
# tis-620 because it is ambiguous in ICU on some platforms
# but should return the preferred encoding
lmap enc {utf-8 tis-620 shiftjis} {
icu tclToIcu $enc
}
} -result {UTF-8 TIS-620 ibm-943_P15A-2003}
test icu-tclToIcu-1 {Map Tcl encoding - no map} -constraints icu -body {
# Should not raise an error
icu tclToIcu dummy
} -result {}
test icu-tclToIcu-2 {error case} -constraints icu -returnCodes error -body {
icu tclToIcu gorp gorp
} -result {wrong # args: should be "icu tclToIcu tclName"}
test icu-icuToTcl-0 {Map ICU encoding} -constraints icu -body {
lmap enc {UTF-8 TIS-620 ibm-943_P15A-2003} {
icu icuToTcl $enc
}
} -result {utf-8 tis-620 cp932}
test icu-icuToTcl-1 {Map ICU encoding - no map} -constraints icu -body {
# Should not raise an error
icu icuToTcl dummy
} -result {}
test icu-icuToTcl-2 {error case} -constraints icu -returnCodes error -body {
icu icuToTcl gorp gorp
} -result {wrong # args: should be "icu icuToTcl icuName"}
###
# icu convertfrom syntax and arg checks
# These tests are NOT for testing encodings, that's elsewhere.
test icu-convertfrom-error-0 {no args} -constraints icu -body {
icu convertfrom
} -result {wrong # args: should be "icu convertfrom ?-profile PROFILE? ICUENCNAME STRING"} -returnCodes error
test icu-convertfrom-error-1 {one arg} -constraints icu -body {
icu convertfrom ASCII
} -result {wrong # args: should be "icu convertfrom ?-profile PROFILE? ICUENCNAME STRING"} -returnCodes error
test icu-convertfrom-error-2 {missing option value} -constraints icu -body {
icu convertfrom -profile strict ASCII
} -result {Missing value for option -profile.} -returnCodes error
test icu-convertfrom-error-3 {-failindex} -constraints icu -body {
icu convertfrom -failindex failindex ASCII abc
} -result {Option -failindex not implemented.} -returnCodes error
test icu-convertfrom-error-4 {extra arg} -constraints icu -body {
icu convertfrom -profile strict extra ASCII abc
} -result {bad option "extra": must be -profile or -failindex} -returnCodes error
test icu-convertfrom-error-5 {invalid profile} -constraints icu -body {
icu convertfrom -profile tcl8 ASCII abc
} -result {Invalid value "tcl8" supplied for option "-profile". Must be "strict" or "replace".} -returnCodes error
test icu-convertfrom-error-6 {invalid encoding} -constraints icu -body {
icu convertfrom nosuchencoding abc
} -result {Could not get encoding converter.*} -match glob -returnCodes error
test icu-convertfrom-0 {default success} -constraints icu -body {
icu convertfrom UTF-8 \xf0\x9f\x98\x80
} -result \U1F600
test icu-convertfrom-1 {-profile strict success} -constraints icu -body {
icu convertfrom -profile strict UTF-8 \xf0\x9f\x98\x80
} -result \U1F600
test icu-convertfrom-2 {-profile replace success} -constraints icu -body {
icu convertfrom -profile replace UTF-8 \xf0\x9f\x98\x80
} -result \U1F600
test icu-convertfrom-3 {default invalid encoding} -constraints icu -body {
icu convertfrom UTF-8 \xC0\x80
} -result {ICU error while decoding. ICU error (12): U_ILLEGAL_CHAR_FOUND} -returnCodes error
test icu-convertfrom-4 {-profile strict invalid encoding} -constraints icu -body {
icu convertfrom -profile strict UTF-8 \xC0\x80
} -result {ICU error while decoding. ICU error (12): U_ILLEGAL_CHAR_FOUND} -returnCodes error
test icu-convertfrom-5 {-profile replace invalid encoding} -constraints icu -body {
icu convertfrom -profile replace UTF-8 \xC0\x80
} -result \UFFFD\uFFFD
###
# icu convertto syntax and arg checks
# These tests are NOT for testing encodings, that's elsewhere.
test icu-convertto-error-0 {no args} -constraints icu -body {
icu convertto
} -result {wrong # args: should be "icu convertto ?-profile PROFILE? ICUENCNAME STRING"} -returnCodes error
test icu-convertto-error-1 {one arg} -constraints icu -body {
icu convertto ASCII
} -result {wrong # args: should be "icu convertto ?-profile PROFILE? ICUENCNAME STRING"} -returnCodes error
test icu-convertto-error-2 {missing option value} -constraints icu -body {
icu convertto -profile strict ASCII
} -result {Missing value for option -profile.} -returnCodes error
test icu-convertto-error-3 {-failindex} -constraints icu -body {
icu convertto -failindex failindex ASCII abc
} -result {Option -failindex not implemented.} -returnCodes error
test icu-convertto-error-4 {extra arg} -constraints icu -body {
icu convertto -profile strict extra ASCII abc
} -result {bad option "extra": must be -profile or -failindex} -returnCodes error
test icu-convertto-error-5 {invalid profile} -constraints icu -body {
icu convertto -profile tcl8 ASCII abc
} -result {Invalid value "tcl8" supplied for option "-profile". Must be "strict" or "replace".} -returnCodes error
test icu-convertto-error-6 {invalid encoding} -constraints icu -body {
icu convertto nosuchencoding abc
} -result {Could not get encoding converter.*} -match glob -returnCodes error
test icu-convertto-0 {default success} -constraints icu -body {
icu convertto UTF-8 \U1F600
} -result \xf0\x9f\x98\x80
test icu-convertto-1 {-profile strict success} -constraints icu -body {
icu convertto -profile strict UTF-8 \U1F600
} -result \xf0\x9f\x98\x80
test icu-convertto-2 {-profile replace success} -constraints icu -body {
icu convertto -profile replace UTF-8 \U1F600
} -result \xf0\x9f\x98\x80
test icu-convertto-3 {default unencodable character} -constraints icu -body {
icu convertto ISO-8859-2 \U1F600
} -result {ICU error while encoding. ICU error (10): U_INVALID_CHAR_FOUND} -returnCodes error
test icu-convertto-4 {-profile strict unencodable character} -constraints icu -body {
icu convertto -profile strict ISO-8859-2 \U1F600
} -result {ICU error while encoding. ICU error (10): U_INVALID_CHAR_FOUND} -returnCodes error
test icu-convertto-5 {-profile replace unencodable character} -constraints icu -body {
icu convertto -profile replace ISO-8859-2 \U1F600
} -result \x1A
###
# Basic tests for normalization
test icu-normalize-error-0 {no args} -constraints icu -body {
icu normalize
} -result {wrong # args: should be "icu normalize ?-profile PROFILE? ?-mode MODE? STRING"} -returnCodes error
test icu-normalize-error-1 {missing -profile arg} -constraints icu -body {
icu normalize -profile STRING
} -result {Missing value for option -profile.} -returnCodes error
test icu-normalize-error-2 {missing -mode arg} -constraints icu -body {
icu normalize -mode STRING
} -result {Missing value for option -mode.} -returnCodes error
test icu-normalize-error-3 {extra arg} -constraints icu -body {
icu normalize -profile strict STRING arg
} -result {bad option "STRING": must be -profile or -mode} -returnCodes error
test icu-normalize-error-4 {invalid profile} -constraints icu -body {
icu normalize -profile tcl8 ASCII abc
} -result {Invalid value "tcl8" supplied for option "-profile". Must be "strict" or "replace".} -returnCodes error
test icu-normalize-error-6 {invalid mode} -constraints icu -body {
icu normalize -mode xxx ASCII abc
} -result {bad normalization mode "xxx": must be nfc, nfd, nfkc, or nfkd} -returnCodes error
# Source is composed
set s \uFB01anc\u00e9
test icu-normalize-0 {Default normalization} -constraints icu -body {
icu normalize $s
} -result \uFB01anc\u00e9
test icu-normalize-nfc-0 {NFC normalization} -constraints icu -body {
icu normalize -mode nfc $s
} -result \uFB01anc\u00e9
test icu-normalize-nfd-0 {NFD normalization} -constraints icu -body {
icu normalize -mode nfd $s
} -result \uFB01ance\u0301
test icu-normalize-nfkc-0 {NFKC normalization} -constraints icu -body {
icu normalize -mode nfkc $s
} -result fianc\u00e9
test icu-normalize-nfkd-0 {NFKD normalization} -constraints icu -body {
icu normalize -mode nfkd $s
} -result fiance\u0301
# Source is decomposed
set s \uFB01ance\u0301
test icu-normalize-1 {Default normalization} -constraints icu -body {
icu normalize $s
} -result \uFB01anc\u00e9
test icu-normalize-nfc-1 {NFC normalization} -constraints icu -body {
icu normalize -mode nfc $s
} -result \uFB01anc\u00e9
test icu-normalize-nfd-1 {NFD normalization} -constraints icu -body {
icu normalize -mode nfd $s
} -result \uFB01ance\u0301
test icu-normalize-nfkc-1 {NFKC normalization} -constraints icu -body {
icu normalize -mode nfkc $s
} -result fianc\u00e9
test icu-normalize-nfkd-1 {NFKD normalization} -constraints icu -body {
icu normalize -mode nfkd $s
} -result fiance\u0301
# Source has multiple diacritics with different canonical ordering
foreach s [list \u1EC7 e\u0302\u0323 e\u0323\u0302] {
test icu-normalize-nfc-2-$s {fully composed} -constraints icu -body {
icu normalize -mode nfc $s
} -result \u1EC7
test icu-normalize-nfc-3-$s {fully decomposed} -constraints icu -body {
icu normalize -mode nfd $s
} -result e\u0323\u0302
}
}
namespace delete icu
::tcltest::cleanupTests
|
Changes to tests/if.test.
| ︙ | ︙ | |||
177 178 179 180 181 182 183 |
} -result 3
test if-1.17 {TclCompileIfCmd: if/elseif test in quotes} -setup {
set a {}
} -body {
if {"0 < 3"} {set a 1}
} -returnCodes error -cleanup {
unset a
| | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
} -result 3
test if-1.17 {TclCompileIfCmd: if/elseif test in quotes} -setup {
set a {}
} -body {
if {"0 < 3"} {set a 1}
} -returnCodes error -cleanup {
unset a
} -result {expected boolean value but got a list}
test if-2.1 {TclCompileIfCmd: "elseif" after if/elseif test} -setup {
set a {}
} -body {
if 3>4 {set a 1} elseif 1 {set a 2}
return $a
} -cleanup {
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
test if-5.17 {if cmd with computed command names: if/elseif test in quotes} -setup {
set a {}
} -body {
set z if
$z {"0 < 3"} {set a 1}
} -returnCodes error -cleanup {
unset a z
| | | 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 |
test if-5.17 {if cmd with computed command names: if/elseif test in quotes} -setup {
set a {}
} -body {
set z if
$z {"0 < 3"} {set a 1}
} -returnCodes error -cleanup {
unset a z
} -result {expected boolean value but got a list}
test if-6.1 {if cmd with computed command names: "elseif" after if/elseif test} -setup {
set a {}
} -body {
set z if
$z 3>4 {set a 1} elseif 1 {set a 2}
return $a
|
| ︙ | ︙ | |||
1256 1257 1258 1259 1260 1261 1262 |
proc iftraceproc {args} {
upvar #0 iftracecounter counter
set argc [llength $args]
set extraargs [lrange $args 0 [expr {$argc - 4}]]
set name [lindex $args [expr {$argc - 3}]]
upvar 1 $name var
if {[incr counter] % 2 == 1} {
| | | | | 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 |
proc iftraceproc {args} {
upvar #0 iftracecounter counter
set argc [llength $args]
set extraargs [lrange $args 0 [expr {$argc - 4}]]
set name [lindex $args [expr {$argc - 3}]]
upvar 1 $name var
if {[incr counter] % 2 == 1} {
set var "$counter oops [concat $extraargs]"
} else {
set var "$counter + [concat $extraargs]"
}
}
trace add variable iftracevar read [list iftraceproc 10]
list [catch {if "$iftracevar + 20" {}} a] $a \
[catch {if "$iftracevar + 20" {}} b] $b
} -cleanup {
unset iftracevar iftracecounter a b
} -match glob -result {1 {*} 0 {}}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/incr-old.test.
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
test incr-old-2.9 {incr errors} {
set x +
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "+"}}
test incr-old-2.10 {incr errors} {
set x {20 x}
list [catch {incr x 1} msg] $msg
| | | 81 82 83 84 85 86 87 88 89 90 91 92 |
test incr-old-2.9 {incr errors} {
set x +
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "+"}}
test incr-old-2.10 {incr errors} {
set x {20 x}
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got a list}}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/incr.test.
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
} {17 17}
test incr-1.10 {TclCompileIncrCmd: no increment given} {
set i 10
list [incr i] $i
} {11 11}
test incr-1.11 {TclCompileIncrCmd: simple global name} {
proc p {} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} {17 17}
test incr-1.10 {TclCompileIncrCmd: no increment given} {
set i 10
list [incr i] $i
} {11 11}
test incr-1.11 {TclCompileIncrCmd: simple global name} {
proc p {} {
global i
set i 54
incr i
}
p
} {55}
test incr-1.12 {TclCompileIncrCmd: simple local name} {
proc p {} {
set foo 100
incr foo
}
p
} {101}
test incr-1.13 {TclCompileIncrCmd: simple but new (unknown) local name} {
proc p {} {
incr bar
}
p
} 1
test incr-1.14 {TclCompileIncrCmd: simple local name, >255 locals} {
proc 260locals {} {
# create 260 locals
set a0 0; set a1 0; set a2 0; set a3 0; set a4 0
set a5 0; set a6 0; set a7 0; set a8 0; set a9 0
set b0 0; set b1 0; set b2 0; set b3 0; set b4 0
set b5 0; set b6 0; set b7 0; set b8 0; set b9 0
set c0 0; set c1 0; set c2 0; set c3 0; set c4 0
set c5 0; set c6 0; set c7 0; set c8 0; set c9 0
set d0 0; set d1 0; set d2 0; set d3 0; set d4 0
set d5 0; set d6 0; set d7 0; set d8 0; set d9 0
set e0 0; set e1 0; set e2 0; set e3 0; set e4 0
set e5 0; set e6 0; set e7 0; set e8 0; set e9 0
set f0 0; set f1 0; set f2 0; set f3 0; set f4 0
set f5 0; set f6 0; set f7 0; set f8 0; set f9 0
set g0 0; set g1 0; set g2 0; set g3 0; set g4 0
set g5 0; set g6 0; set g7 0; set g8 0; set g9 0
set h0 0; set h1 0; set h2 0; set h3 0; set h4 0
set h5 0; set h6 0; set h7 0; set h8 0; set h9 0
set i0 0; set i1 0; set i2 0; set i3 0; set i4 0
set i5 0; set i6 0; set i7 0; set i8 0; set i9 0
set j0 0; set j1 0; set j2 0; set j3 0; set j4 0
set j5 0; set j6 0; set j7 0; set j8 0; set j9 0
set k0 0; set k1 0; set k2 0; set k3 0; set k4 0
set k5 0; set k6 0; set k7 0; set k8 0; set k9 0
set l0 0; set l1 0; set l2 0; set l3 0; set l4 0
set l5 0; set l6 0; set l7 0; set l8 0; set l9 0
set m0 0; set m1 0; set m2 0; set m3 0; set m4 0
set m5 0; set m6 0; set m7 0; set m8 0; set m9 0
set n0 0; set n1 0; set n2 0; set n3 0; set n4 0
set n5 0; set n6 0; set n7 0; set n8 0; set n9 0
set o0 0; set o1 0; set o2 0; set o3 0; set o4 0
set o5 0; set o6 0; set o7 0; set o8 0; set o9 0
set p0 0; set p1 0; set p2 0; set p3 0; set p4 0
set p5 0; set p6 0; set p7 0; set p8 0; set p9 0
set q0 0; set q1 0; set q2 0; set q3 0; set q4 0
set q5 0; set q6 0; set q7 0; set q8 0; set q9 0
set r0 0; set r1 0; set r2 0; set r3 0; set r4 0
set r5 0; set r6 0; set r7 0; set r8 0; set r9 0
set s0 0; set s1 0; set s2 0; set s3 0; set s4 0
set s5 0; set s6 0; set s7 0; set s8 0; set s9 0
set t0 0; set t1 0; set t2 0; set t3 0; set t4 0
set t5 0; set t6 0; set t7 0; set t8 0; set t9 0
set u0 0; set u1 0; set u2 0; set u3 0; set u4 0
set u5 0; set u6 0; set u7 0; set u8 0; set u9 0
set v0 0; set v1 0; set v2 0; set v3 0; set v4 0
set v5 0; set v6 0; set v7 0; set v8 0; set v9 0
set w0 0; set w1 0; set w2 0; set w3 0; set w4 0
set w5 0; set w6 0; set w7 0; set w8 0; set w9 0
set x0 0; set x1 0; set x2 0; set x3 0; set x4 0
set x5 0; set x6 0; set x7 0; set x8 0; set x9 0
set y0 0; set y1 0; set y2 0; set y3 0; set y4 0
set y5 0; set y6 0; set y7 0; set y8 0; set y9 0
set z0 0; set z1 0; set z2 0; set z3 0; set z4 0
set z5 0; set z6 0; set z7 0; set z8 0; set z9 0
# now increment the last one (local var index > 255)
incr z9
}
260locals
} {1}
test incr-1.15 {TclCompileIncrCmd: variable is array} -setup {
unset -nocomplain a
} -body {
set a(foo) 27
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
} -returnCodes error -result {expected integer but got " - "}
test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} -setup {
catch {unset array}
} -body {
set array(\$foo) 4
incr {array($foo)}
} -result 5
# Check "incr" and computed command names.
unset -nocomplain x i
test incr-2.0 {incr and computed command names} {
set i 5
set z incr
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
} -returnCodes error -result {expected integer but got " - "}
test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} -setup {
catch {unset array}
} -body {
set array(\$foo) 4
incr {array($foo)}
} -result 5
test incr-1.31 {no overflow in TclCompileIncrCmd and Tcl_IncrObjCmd, bug [7179c6724cd38271]} {
set res [list]
# TclCompileIncrCmd: compiled incr TEBC with immutable constant offs (INST_INCR_*_IMM instructions):
lappend res [set i 0; incr i 0x7FFFFFFF]
lappend res [set i 0; incr i 0xFFFFFF80]
lappend res [set i 0; incr i 0xFFFFFF81]
lappend res [set i 0; incr i 0xFFFFFFFF]
lappend res [set i 0; incr i 0x10000007F]
lappend res [set i 0; incr i 0x100000080]
lappend res [set i 0; incr i 0x7FFFFFFFFFFFFFFF]
lappend res [set i 0; incr i 0xFFFFFFFFFFFFFF80]
lappend res [set i 0; incr i 0xFFFFFFFFFFFFFF81]
lappend res [set i 0; incr i 0xFFFFFFFFFFFFFFFF]
lappend res [set i 0; incr i 0x1000000000000007F]
lappend res [set i 0; incr i 0x10000000000000080]
# TclCompileIncrCmd: compiled incr TEBC with dynamic offs (INST_INCR_* instructions without _IMM):
lappend res [set i 0; incr i [set x 0x7FFFFFFF]]
lappend res [set i 0; incr i [set x 0xFFFFFF80]]
lappend res [set i 0; incr i [set x 0xFFFFFF81]]
lappend res [set i 0; incr i [set x 0xFFFFFFFF]]
lappend res [set i 0; incr i [set x 0x10000007F]]
lappend res [set i 0; incr i [set x 0x100000080]]
lappend res [set i 0; incr i [set x 0x7FFFFFFFFFFFFFFF]]
lappend res [set i 0; incr i [set x 0xFFFFFFFFFFFFFF80]]
lappend res [set i 0; incr i [set x 0xFFFFFFFFFFFFFF81]]
lappend res [set i 0; incr i [set x 0xFFFFFFFFFFFFFFFF]]
lappend res [set i 0; incr i [set x 0x1000000000000007F]]
lappend res [set i 0; incr i [set x 0x10000000000000080]]
# Tcl_IncrObjCmd: non-compiled incr command (or NRE):
set cmd incr
lappend res [set i 0; $cmd i 0x7FFFFFFF]
lappend res [set i 0; $cmd i 0xFFFFFF80]
lappend res [set i 0; $cmd i 0xFFFFFF81]
lappend res [set i 0; $cmd i 0xFFFFFFFF]
lappend res [set i 0; $cmd i 0x10000007F]
lappend res [set i 0; $cmd i 0x100000080]
lappend res [set i 0; $cmd i 0x7FFFFFFFFFFFFFFF]
lappend res [set i 0; $cmd i 0xFFFFFFFFFFFFFF80]
lappend res [set i 0; $cmd i 0xFFFFFFFFFFFFFF81]
lappend res [set i 0; $cmd i 0xFFFFFFFFFFFFFFFF]
lappend res [set i 0; $cmd i 0x1000000000000007F]
lappend res [set i 0; $cmd i 0x10000000000000080]
} [lrepeat 3 \
[expr 0x7FFFFFFF] \
[expr 0xFFFFFF80] \
[expr 0xFFFFFF81] \
[expr 0xFFFFFFFF] \
[expr 0x10000007F] \
[expr 0x100000080] \
[expr 0x7FFFFFFFFFFFFFFF] \
[expr 0xFFFFFFFFFFFFFF80] \
[expr 0xFFFFFFFFFFFFFF81] \
[expr 0xFFFFFFFFFFFFFFFF] \
[expr 0x1000000000000007F] \
[expr 0x10000000000000080] \
]
# Check "incr" and computed command names.
unset -nocomplain x i
test incr-2.0 {incr and computed command names} {
set i 5
set z incr
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
set z incr
set i 10
list [$z i] $i
} {11 11}
test incr-2.11 {incr command (not compiled): simple global name} {
proc p {} {
set z incr
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set z incr
set i 10
list [$z i] $i
} {11 11}
test incr-2.11 {incr command (not compiled): simple global name} {
proc p {} {
set z incr
global i
set i 54
$z i
}
p
} {55}
test incr-2.12 {incr command (not compiled): simple local name} {
proc p {} {
set z incr
set foo 100
$z foo
}
p
} {101}
test incr-2.13 {incr command (not compiled): simple but new (unknown) local name} {
proc p {} {
set z incr
$z bar
}
p
} 1
test incr-2.14 {incr command (not compiled): simple local name, >255 locals} {
proc 260locals {} {
set z incr
# create 260 locals
set a0 0; set a1 0; set a2 0; set a3 0; set a4 0
set a5 0; set a6 0; set a7 0; set a8 0; set a9 0
set b0 0; set b1 0; set b2 0; set b3 0; set b4 0
set b5 0; set b6 0; set b7 0; set b8 0; set b9 0
set c0 0; set c1 0; set c2 0; set c3 0; set c4 0
set c5 0; set c6 0; set c7 0; set c8 0; set c9 0
set d0 0; set d1 0; set d2 0; set d3 0; set d4 0
set d5 0; set d6 0; set d7 0; set d8 0; set d9 0
set e0 0; set e1 0; set e2 0; set e3 0; set e4 0
set e5 0; set e6 0; set e7 0; set e8 0; set e9 0
set f0 0; set f1 0; set f2 0; set f3 0; set f4 0
set f5 0; set f6 0; set f7 0; set f8 0; set f9 0
set g0 0; set g1 0; set g2 0; set g3 0; set g4 0
set g5 0; set g6 0; set g7 0; set g8 0; set g9 0
set h0 0; set h1 0; set h2 0; set h3 0; set h4 0
set h5 0; set h6 0; set h7 0; set h8 0; set h9 0
set i0 0; set i1 0; set i2 0; set i3 0; set i4 0
set i5 0; set i6 0; set i7 0; set i8 0; set i9 0
set j0 0; set j1 0; set j2 0; set j3 0; set j4 0
set j5 0; set j6 0; set j7 0; set j8 0; set j9 0
set k0 0; set k1 0; set k2 0; set k3 0; set k4 0
set k5 0; set k6 0; set k7 0; set k8 0; set k9 0
set l0 0; set l1 0; set l2 0; set l3 0; set l4 0
set l5 0; set l6 0; set l7 0; set l8 0; set l9 0
set m0 0; set m1 0; set m2 0; set m3 0; set m4 0
set m5 0; set m6 0; set m7 0; set m8 0; set m9 0
set n0 0; set n1 0; set n2 0; set n3 0; set n4 0
set n5 0; set n6 0; set n7 0; set n8 0; set n9 0
set o0 0; set o1 0; set o2 0; set o3 0; set o4 0
set o5 0; set o6 0; set o7 0; set o8 0; set o9 0
set p0 0; set p1 0; set p2 0; set p3 0; set p4 0
set p5 0; set p6 0; set p7 0; set p8 0; set p9 0
set q0 0; set q1 0; set q2 0; set q3 0; set q4 0
set q5 0; set q6 0; set q7 0; set q8 0; set q9 0
set r0 0; set r1 0; set r2 0; set r3 0; set r4 0
set r5 0; set r6 0; set r7 0; set r8 0; set r9 0
set s0 0; set s1 0; set s2 0; set s3 0; set s4 0
set s5 0; set s6 0; set s7 0; set s8 0; set s9 0
set t0 0; set t1 0; set t2 0; set t3 0; set t4 0
set t5 0; set t6 0; set t7 0; set t8 0; set t9 0
set u0 0; set u1 0; set u2 0; set u3 0; set u4 0
set u5 0; set u6 0; set u7 0; set u8 0; set u9 0
set v0 0; set v1 0; set v2 0; set v3 0; set v4 0
set v5 0; set v6 0; set v7 0; set v8 0; set v9 0
set w0 0; set w1 0; set w2 0; set w3 0; set w4 0
set w5 0; set w6 0; set w7 0; set w8 0; set w9 0
set x0 0; set x1 0; set x2 0; set x3 0; set x4 0
set x5 0; set x6 0; set x7 0; set x8 0; set x9 0
set y0 0; set y1 0; set y2 0; set y3 0; set y4 0
set y5 0; set y6 0; set y7 0; set y8 0; set y9 0
set z0 0; set z1 0; set z2 0; set z3 0; set z4 0
set z5 0; set z6 0; set z7 0; set z8 0; set z9 0
# now increment the last one (local var index > 255)
$z z9
}
260locals
} {1}
test incr-2.15 {incr command (not compiled): variable is array} -setup {
unset -nocomplain a
} -body {
set z incr
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 |
list [catch {incr x 1a} msg] $msg $::errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
(reading increment)
invoked from within
"incr x 1a"}}
test incr-2.32 {incr command (compiled): bad pure list increment} {
list [catch {incr x [list 1 2]} msg] $msg $::errorInfo
| | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
list [catch {incr x 1a} msg] $msg $::errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
(reading increment)
invoked from within
"incr x 1a"}}
test incr-2.32 {incr command (compiled): bad pure list increment} {
list [catch {incr x [list 1 2]} msg] $msg $::errorInfo
} {1 {expected integer but got a list} {expected integer but got a list
(reading increment)
invoked from within
"incr x [list 1 2]"}}
test incr-2.33 {incr command (compiled): bad pure dict increment} {
list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo
} {1 {expected integer but got a list} {expected integer but got a list
(reading increment)
invoked from within
"incr x [dict create 1 2]"}}
test incr-3.1 {increment by wide amount: bytecode route} {
set x 0
incr x 123123123123
|
| ︙ | ︙ |
Changes to tests/indexObj.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testgetintforindex [llength [info commands testgetintforindex]]
testConstraint testparseargs [llength [info commands testparseargs]]
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]
| < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testgetintforindex [llength [info commands testgetintforindex]]
testConstraint testparseargs [llength [info commands testparseargs]]
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
testindexobj 1 1 abc abc def xyz alm
} {0}
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj {
set x ""
testgetindexfromobjstruct $x -1 32
} "wrong # args: should be \"testgetindexfromobjstruct {} -1 32\""
test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
testparseargs
| | | | | | > > | | | | > > > > > > > > > > > > > > > | | 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 |
test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj {
set x ""
testgetindexfromobjstruct $x -1 32
} "wrong # args: should be \"testgetindexfromobjstruct {} -1 32\""
test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
testparseargs
} {0 1 testparseargs NULL NULL}
test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
testparseargs -bool
} {1 1 testparseargs NULL NULL}
test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
testparseargs -bool bar
} {1 2 {testparseargs bar} NULL NULL}
test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
testparseargs bar
} {0 2 {testparseargs bar} NULL NULL}
test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
testparseargs -help
} -returnCodes error -result {Command-specific options:
-bool: booltest
-colormode: color mode
-media: media page size
--: Marks the end of the options
-help: Print summary of command-line options and abort}
test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs {
testparseargs -- -bool -help
} {0 3 {testparseargs -bool -help} NULL NULL}
test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs {
testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0
} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0} NULL NULL}
test indexObj-7.8 {Tcl_ParseArgsObjv} testparseargs {
testparseargs -color Nothing
} {0 1 testparseargs Nothing NULL}
test indexObj-7.9 {Tcl_ParseArgsObjv} testparseargs {
testparseargs -media A4
} {0 1 testparseargs NULL {Paper size is ISO A4}}
test indexObj-7.10 {Tcl_ParseArgsObjv} testparseargs {
testparseargs -media A4 -color Somecolor
} {0 1 testparseargs Somecolor {Paper size is ISO A4}}
test indexObj-7.11 {Tcl_ParseArgsObjv} testparseargs {
testparseargs -color othercolor -media Letter
} {0 1 testparseargs othercolor {Paper size is US Letter}}
test indexObj-7.12 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
testparseargs -color othercolor -media Nosuchmedia
} -returnCodes error -result {bad media "Nosuchmedia": must be A4, Legal, or Letter}
test indexObj-8.1 {Tcl_GetIntForIndex integer} testgetintforindex {
testgetintforindex 0 0
} 0
test indexObj-8.2 {Tcl_GetIntForIndex integer} testgetintforindex {
testgetintforindex -1 0
} -1
test indexObj-8.3 {Tcl_GetIntForIndex integer} testgetintforindex {
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 |
} -3
test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex {
testgetintforindex end -1
} -1
test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex {
testgetintforindex end -2
} -2
| | | > > > | > | | | | < > > | | | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
} -3
test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex {
testgetintforindex end -1
} -1
test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex {
testgetintforindex end -2
} -2
test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex {
testgetintforindex end+1 -1
} [expr {[testConstraint has64BitLengths] ? 9223372036854775807 : 2147483647}]
test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex {
testgetintforindex end+1 -2
} -1
test indexObj-8.16 {Tcl_GetIntForIndex integer} testgetintforindex {
testgetintforindex -1 -1
} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}]
test indexObj-8.17 {Tcl_GetIntForIndex integer} testgetintforindex {
testgetintforindex -2 -1
} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}]
test indexObj-8.18 {Tcl_GetIntForIndex n-m} testgetintforindex {
testgetintforindex 2-3 -1
} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}]
test indexObj-8.19 {Tcl_GetIntForIndex n-m} testgetintforindex {
testgetintforindex 2-3 0
} -1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/info.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
proc t1 {a b} {set c 123; set d $c}
t1 1 2
info args t1
} {a b}
test info-1.7 {info args option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
| | | | | | 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 |
proc t1 {a b} {set c 123; set d $c}
t1 1 2
info args t1
} {a b}
test info-1.7 {info args option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info args p] [info args q]
}
} {x {y z}}
test info-2.1 {info body option} {
proc t1 {} {body of t1}
info body t1
} {body of t1}
test info-2.2 {info body option} -body {
info body set
} -returnCodes error -result {"set" isn't a procedure}
test info-2.3 {info body option} -body {
info args set 1
} -returnCodes error -result {wrong # args: should be "info args procname"}
test info-2.4 {info body option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info body p] [info body q]
}
} {{return "x=$x"} {return "y=$y"}}
# Prior to 8.3.0 this would cause a crash because [info body]
# would return the bytecompiled version of foo, which the catch
# would then try and eval out of the foo context, accessing
# compiled local indices
test info-2.5 {info body option, returning bytecompiled bodies} -body {
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
} -returnCodes error -result {wrong # args: should be "info cmdcount"}
test info-4.1 {info commands option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info commands] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
| | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
} -returnCodes error -result {wrong # args: should be "info cmdcount"}
test info-4.1 {info commands option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info commands] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
[string match {* set *} $x] [string match {* list *} $x]
} -cleanup {unset x} -result {1 1 1 1}
test info-4.2 {info commands option} -body {
proc t1 {} {}
rename t1 {}
string match {* t1 *} \
[info comm]
} -result 0
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
set a(0) 88
proc t1 {{a 18} b} {}
info default t1 a a
} -returnCodes error -result {can't set "a": variable is array}
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
| | | | | | | | 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 |
set a(0) 88
proc t1 {{a 18} b} {}
info default t1 a a
} -returnCodes error -result {can't set "a": variable is array}
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
test info-7.1 {info exists option} -body {
set value foo
info exists value
} -cleanup {unset value} -result 1
test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body {
info exists _nonexistent_
} -result 0
test info-7.3 {info exists option} {
proc t1 {x} {return [info exists x]}
t1 2
} 1
test info-7.4 {info exists option} -body {
proc t1 {x} {
global _nonexistent_
return [info exists _nonexistent_]
}
t1 2
} -setup {unset -nocomplain _nonexistent_} -result 0
test info-7.5 {info exists option} {
proc t1 {x} {
set y 47
return [info exists y]
}
t1 2
} 1
test info-7.6 {info exists option} {
proc t1 {x} {return [info exists value]}
t1 2
} 0
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
test info-8.1 {info globals option} -body {
set x 1
set y 2
set value 23
set a " [info globals] "
list [string match {* x *} $a] [string match {* y *} $a] \
| | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
test info-8.1 {info globals option} -body {
set x 1
set y 2
set value 23
set a " [info globals] "
list [string match {* x *} $a] [string match {* y *} $a] \
[string match {* value *} $a] [string match {* _foobar_ *} $a]
} -cleanup {unset x y value a} -result {1 1 1 0}
test info-8.2 {info globals option} -body {
set _xxx1 1
set _xxx2 2
lsort [info g _xxx*]
} -cleanup {unset _xxx1 _xxx2} -result {_xxx1 _xxx2}
test info-8.3 {info globals option} -returnCodes error -body {
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 |
}
test info-9.1 {info level option} {
info level
} 0
test info-9.2 {info level option} {
proc t1 {a b} {
| | | | | | | | | | | 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 |
}
test info-9.1 {info level option} {
info level
} 0
test info-9.2 {info level option} {
proc t1 {a b} {
set x [info le]
set y [info level 1]
list $x $y
}
t1 146 testString
} {1 {t1 146 testString}}
test info-9.3 {info level option} {
proc t1 {a b} {
t2 [expr {$a*2}] $b
}
proc t2 {x y} {
list [info level] [info level 1] [info level 2] [info level -1] \
[info level 0]
}
t1 146 {a {b c} {{{c}}}}
} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
test info-9.4 {info level option} {
proc t1 {} {
set x [info level]
set y [info level 1]
list $x $y
}
t1
} {1 t1}
test info-9.5 {info level option} -body {
info level 1 2
} -returnCodes error -result {wrong # args: should be "info level ?number?"}
test info-9.6 {info level option} -body {
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 |
unset tcl_library
info library
} -returnCodes error -result {no library has been specified for Tcl}
set tcl_library $savedLibrary; unset savedLibrary
test info-11.1 {info loaded option} -body {
info loaded a b c
| | | | | | | | | | | | | | | | 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 |
unset tcl_library
info library
} -returnCodes error -result {no library has been specified for Tcl}
set tcl_library $savedLibrary; unset savedLibrary
test info-11.1 {info loaded option} -body {
info loaded a b c
} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?prefix?"}
test info-11.2 {info loaded option} -body {
info loaded {}; info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
test info-12.1 {info locals option} -body {
set a 22
proc t1 {x y} {
set b 13
set c testing
global a
global aa
set aa 23
return [info locals]
}
lsort [t1 23 24]
} -cleanup {unset a aa} -result {b c x y}
test info-12.2 {info locals option} {
proc t1 {x y} {
set xx1 2
set xx2 3
set y 4
return [info locals x*]
}
lsort [t1 2 3]
} {x xx1 xx2}
test info-12.3 {info locals option} -body {
info locals 1 2
} -returnCodes error -result {wrong # args: should be "info locals ?pattern?"}
test info-12.4 {info locals option} {
info locals
} {}
test info-12.5 {info locals option} {
proc t1 {} {return [info locals]}
t1
} {}
test info-12.6 {info locals vs unset compiled locals} {
proc t1 {lst} {
foreach $lst $lst {}
unset lst
return [info locals]
}
lsort [t1 {a b c c d e f}]
} {a b c d e f}
test info-12.7 {info locals with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info locals
}
t1
} {a}
test info-13.1 {info nameofexecutable option} -returnCodes error -body {
info nameofexecutable foo
} -result {wrong # args: should be "info nameofexecutable"}
|
| ︙ | ︙ | |||
471 472 473 474 475 476 477 |
} -returnCodes error -result {can't read "tcl_patchLevel": no such variable}
test info-15.1 {info procs option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info procs] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
| | | | | | | | | | | | 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 |
} -returnCodes error -result {can't read "tcl_patchLevel": no such variable}
test info-15.1 {info procs option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info procs] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
[string match {* _undefined_ *} $x]
} -cleanup {unset x} -result {1 1 0}
test info-15.2 {info procs option} {
proc _tt1 {} {}
proc _tt2 {} {}
lsort [info pr _tt*]
} {_tt1 _tt2}
catch {rename _tt1 {}}
catch {rename _tt2 {}}
test info-15.3 {info procs option} -body {
info procs 2 3
} -returnCodes error -result {wrong # args: should be "info procs ?pattern?"}
test info-15.4 {info procs option} -setup {
catch {namespace delete test_ns_info2}
} -body {
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
proc r {} {}
list [lsort [info procs]] [info procs p*]
}
} -result {{p q r} p}
test info-15.5 {info procs option with a proc in a namespace} -setup {
catch {namespace delete test_ns_info2}
} -body {
namespace eval test_ns_info2 {
proc p1 { arg } {
puts cmd
}
proc p2 { arg } {
puts cmd
}
}
info procs ::test_ns_info2::p1
} -result {::test_ns_info2::p1}
test info-15.6 {info procs option with a pattern in a namespace} -setup {
catch {namespace delete test_ns_info2}
} -body {
namespace eval test_ns_info2 {
proc p1 { arg } {
puts cmd
}
proc p2 { arg } {
puts cmd
}
}
lsort [info procs ::test_ns_info2::p*]
} -result [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
test info-15.7 {info procs option with a global shadowing proc} -setup {
catch {namespace delete test_ns_info2}
} -body {
proc string_cmd { arg } {
puts cmd
}
namespace eval test_ns_info2 {
proc string_cmd { arg } {
puts cmd
}
}
info procs test_ns_info2::string*
} -result {::test_ns_info2::string_cmd}
# This regression test is currently commented out because it requires
# that the implementation of "info procs" looks into the global namespace,
# which it does not (in contrast to "info commands")
test info-15.8 {info procs option with a global shadowing proc} -setup {
catch {namespace delete test_ns_info2}
} -constraints knownBug -body {
proc string_cmd { arg } {
puts cmd
}
proc string_cmd2 { arg } {
puts cmd
}
namespace eval test_ns_info2 {
proc string_cmd { arg } {
puts cmd
}
}
namespace eval test_ns_info2 {
lsort [info procs string*]
}
} -result [lsort [list string_cmd string_cmd2]]
test info-16.1 {info script option} -returnCodes error -body {
info script x x
} -result {wrong # args: should be "info script ?filename?"}
test info-16.2 {info script option} {
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
info sharedlibextension foo
} -result {wrong # args: should be "info sharedlibextension"}
test info-18.1 {info tclversion option} -body {
scan [info tclversion] "%d.%d%c" a b c
} -cleanup {unset -nocomplain a b c} -result 2
test info-18.2 {info tclversion option} -body {
| | | | | | | | | | | 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 |
info sharedlibextension foo
} -result {wrong # args: should be "info sharedlibextension"}
test info-18.1 {info tclversion option} -body {
scan [info tclversion] "%d.%d%c" a b c
} -cleanup {unset -nocomplain a b c} -result 2
test info-18.2 {info tclversion option} -body {
info tclv 2
} -returnCodes error -result {wrong # args: should be "info tclversion"}
test info-18.3 {info tclversion option} -body {
unset tcl_version
info tclversion
} -returnCodes error -setup {
set t $tcl_version
} -cleanup {
set tcl_version $t; unset t
} -result {can't read "tcl_version": no such variable}
test info-19.1 {info vars option} -body {
set a 1
set b 2
proc t1 {x y} {
global a b
set c 33
return [info vars]
}
lsort [t1 18 19]
} -cleanup {unset a b} -result {a b c x y}
test info-19.2 {info vars option} -body {
set xxx1 1
set xxx2 2
proc t1 {xxa y} {
global xxx1 xxx2
set c 33
return [info vars x*]
}
lsort [t1 18 19]
} -cleanup {unset xxx1 xxx2} -result {xxa xxx1 xxx2}
test info-19.3 {info vars option} {
lsort [info vars]
} [lsort [info globals]]
test info-19.4 {info vars option} -returnCodes error -body {
info vars a b
} -result {wrong # args: should be "info vars ?pattern?"}
test info-19.5 {info vars with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info vars
}
t1
} {a}
test info-19.6 {info vars: Bug 1072654} -setup {
namespace eval :: unset -nocomplain foo
catch {namespace delete x}
} -body {
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 |
} {
type source line 1587 file info.test cmd {info frame 0} proc ::a level 0
type source line 1589 file info.test cmd {info frame 0} proc ::a level 0}
test info-30.17 {bs+nl in multi-body switch, direct} {
switch -regexp -- {key } \
^key { reduce [info frame 0] ;# 1601 } \
| | | | 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 |
} {
type source line 1587 file info.test cmd {info frame 0} proc ::a level 0
type source line 1589 file info.test cmd {info frame 0} proc ::a level 0}
test info-30.17 {bs+nl in multi-body switch, direct} {
switch -regexp -- {key } \
^key { reduce [info frame 0] ;# 1601 } \
\t### { } \
{[0-9]*} { }
} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} {
proc abra {script} {
append script "\n# end of script"
uplevel 1 $script
}
|
| ︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 |
test info-30.20 {bs+nl in single-body switch, direct} {
switch -regexp -- {key } { \
^key { reduce \
[info frame 0] }
\t### { }
| | | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 |
test info-30.20 {bs+nl in single-body switch, direct} {
switch -regexp -- {key } { \
^key { reduce \
[info frame 0] }
\t### { }
{[0-9]*} { }
}
} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.21 {bs+nl in if, full compiled} {
proc a {value} {
if {$value} \
{info frame 0} \
|
| ︙ | ︙ | |||
2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 |
test info-33.35 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
namespace eval ::testinfocmdtype {
apply {cmds {
foreach c $cmds {rename $c {}}
} ::testinfocmdtype} [info commands ::testinfocmdtype::*]
}
test info-40.1 {info cmdtype: syntax} -body {
info cmdtype
| > | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 |
test info-33.35 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
namespace eval ::testinfocmdtype {
apply {cmds {
foreach c $cmds {rename $c {}}
} ::testinfocmdtype} [info commands ::testinfocmdtype::*]
}
test info-40.1 {info cmdtype: syntax} -body {
info cmdtype
|
| ︙ | ︙ | |||
2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 |
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
namespace delete ::testinfocmdtype
# -------------------------------------------------------------------------
unset -nocomplain res
test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
}
set body {
set cmd probe
$cmd
}
proc demo {} $body
} -body {
demo
} -cleanup {
unset -nocomplain body
rename demo {}
rename probe {}
} -result 3
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 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 |
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
namespace delete ::testinfocmdtype
# -------------------------------------------------------------------------
unset -nocomplain res
test info-19.7 {info vars: bug [0e4b7fce57], TIP #278 - no global vars resolve} -setup {
catch {namespace delete x}
} -body {
namespace eval x {info vars}
} -cleanup {
namespace delete x
} -result {}
test info-19.8 {info vars: bug [0e4b7fce57], TIP #278 - no global vars resolve} -setup {
catch {namespace delete x}
} -body {
namespace eval x {info vars tcl_platform}
} -cleanup {
namespace delete x
} -result {}
test info-19.9 {info vars: global vars resolved by pattern} -setup {
catch {namespace delete x}
} -body {
namespace eval x {info vars ::tcl_platform}
} -cleanup {
namespace delete x
} -result {::tcl_platform}
test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
}
set body {
set cmd probe
$cmd
}
proc demo {} $body
} -body {
demo
} -cleanup {
unset -nocomplain body
rename demo {}
rename probe {}
} -result 3
test info-41.0 {Bug 0de6c1d79c crash} -setup {
interp create child
child hide info
} -body {
list [child invokehidden info frame] \
[child invokehidden info frame 0] \
[child invokehidden info frame 1] \
[catch {child invokehidden info frame -1} msg] $msg \
[catch {child invokehidden info frame 2} msg] $msg
} -cleanup {
interp delete child
unset -nocomplain msg
} -result {1 {type precompiled} {type precompiled} 1 {bad level "-1"} 1 {bad level "2"}}
test info-41.1 {Bug 0de6c1d79c crash} -setup {
interp create child
child hide info
} -cleanup {
interp delete child
} -body {
child invokehidden info frame
} -result 1
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
|
Changes to tests/init.test.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
[if {$v} {set ::errorInfo}] \
[set v [info exists ::errorCode]] \
[if {$v} {set ::errorCode}]
}
} -cleanup {
interp delete child
} -result {0 {} 0 {}}
# Six cases - white box testing
test init-1.1 {auto_qualify - absolute cmd - namespace} {
auto_qualify ::foo::bar ::blue
} ::foo::bar
test init-1.2 {auto_qualify - absolute cmd - global} {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
[if {$v} {set ::errorInfo}] \
[set v [info exists ::errorCode]] \
[if {$v} {set ::errorCode}]
}
} -cleanup {
interp delete child
} -result {0 {} 0 {}}
test init-0.2 {no init.tcl from empty tcl_library, bug [43c94f95988f3057]} -setup {
cd [makeDirectory tmp]
makeFile {set ::TEST_INIT 1} init.tcl [pwd]
unset -nocomplain org_tcl_lib
if {[info exists ::env(TCL_LIBRARY)]} {
set org_tcl_lib $::env(TCL_LIBRARY)
}
set res [file exists [file join [pwd] init.tcl]]
} -body {
# first without tcl_library set:
interp create child
lappend res [child eval {info exists ::TEST_INIT}]; # must be 0
interp delete child
# then with current directory as tcl_library:
set ::env(TCL_LIBRARY) .
interp create child
lappend res [child eval {info exists ::TEST_INIT}]; # must be 1
interp delete child
set res
} -cleanup {
if {[info exists org_tcl_lib]} {
set ::env(TCL_LIBRARY) $org_tcl_lib
unset org_tcl_lib
} else {
unset -nocomplain ::env(TCL_LIBRARY)
}
removeFile init.tcl [pwd]
cd [workingDirectory]
removeDirectory tmp
unset -nocomplain res
catch { interp delete child }
} -result {1 0 1}
# Six cases - white box testing
test init-1.1 {auto_qualify - absolute cmd - namespace} {
auto_qualify ::foo::bar ::blue
} ::foo::bar
test init-1.2 {auto_qualify - absolute cmd - global} {
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
tcl:::HistAdd
} -returnCodes error -cleanup {
rename ::tcl::HistAdd {}
} -result {wrong # args: should be "tcl:::HistAdd event ?exec?"}
test init-3.0 {random stuff in the auto_index, should still work} {
set auto_index(foo:::bar::blah) {
| | | | | | | | 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 |
tcl:::HistAdd
} -returnCodes error -cleanup {
rename ::tcl::HistAdd {}
} -result {wrong # args: should be "tcl:::HistAdd event ?exec?"}
test init-3.0 {random stuff in the auto_index, should still work} {
set auto_index(foo:::bar::blah) {
namespace eval foo {namespace eval bar {proc blah {} {return 1}}}
}
foo:::bar::blah
} 1
# Tests that compare the error stack trace generated when autoloading with
# that generated when no autoloading is necessary. Ideally they should be the
# same.
set count 0
foreach arg [subst -nocommands -novariables {
c
{argument
which spans
multiple lines}
{argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack}
{argument which spans multiple lines
and is long enough to be truncated and
" <- includes a false lead in the prune point search
and must be longer still to force truncation}
{contrived example: rare circumstance
where the point at which to prune the
error stack cannot be uniquely determined.
foo bar foo
"}
{contrived example: rare circumstance
where the point at which to prune the
error stack cannot be uniquely determined.
|
| ︙ | ︙ |
Changes to tests/internals.tcl.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 |
set result
} result opt]
if {$pipe ne ""} { catch { close $pipe } }
if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} {
return {*}$opt $result
}
if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) )
| | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
set result
} result opt]
if {$pipe ne ""} { catch { close $pipe } }
if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} {
return {*}$opt $result
}
if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) )
|| ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error)
&& [regexp {\munable to (?:re)?alloc\M} $result] )
} {
tcltest::Warn "testWithLimit: wrong limit, result: $result"
tcltest::Skip testWithLimit
}
return {*}$opt $result
}
|
| ︙ | ︙ |
Changes to tests/interp.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] | | > > > > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:home tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:tildeexpand tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:canonical tcl:zipfs:exists tcl:zipfs:info tcl:zipfs:list tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mountdata tcl:zipfs:root tcl:zipfs:unmount unload zipfs}
proc _ms_limit_args {ms {t0 {}}} {
if {$t0 eq {}} { set t0 [clock milliseconds] }
incr t0 $ms
list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}]
}
foreach i [interp children] {
interp delete $i
}
# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} -returnCodes error -body {
|
| ︙ | ︙ | |||
1568 1569 1570 1571 1572 1573 1574 |
interp delete a
list $r $msg
} {0 91}
test interp-20.45 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
| | | | | 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 |
interp delete a
list $r $msg
} {0 91}
test interp-20.45 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.46 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x x} msg] $msg]
interp delete a
set l
} {1 {can only hide global namespace commands (use rename then hide)}}
test interp-20.47 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
proc x {} {}
}
set l [list [catch {interp hide a x foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.48 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x bar::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.49 {interp invokehidden -namespace} -setup {
|
| ︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 |
catch {interp delete a}
} -body {
interp create a
a alias exec foo ;# Relies on exec being a string command!
interp delete a
} -result ""
#
# Interps result transmission
#
test interp-26.1 {result code transmission : interp eval direct} {
# Test that all the possibles error codes from Tcl get passed up
# from the child interp's context to the parent, even though the
| > > > > > > > > > > > > > > > > > > > > > | 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 |
catch {interp delete a}
} -body {
interp create a
a alias exec foo ;# Relies on exec being a string command!
interp delete a
} -result ""
test interp-25.2 {lambda on different interpreters, bug [67d5f75c36cbada6]} -setup {
catch {interp delete a}
interp create a
} -body {
set res {}
set lambda {{} { list OK from lambda }}
lappend res [apply $lambda]
lappend res [a eval [list apply $lambda]]
set lambda [list apply {{} { list OK from lambda }}]
lappend res [eval $lambda]
lappend res [a eval $lambda]
# cover also epoch change (command list is replaced):
a eval {proc list args {return {NO LIST}}}
lappend res [a eval $lambda]
lappend res [eval $lambda]
set res
} -cleanup {
interp delete a
unset -nocomplain res lambda
} -result [list {*}[lrepeat 4 {OK from lambda}] {NO LIST} {OK from lambda}]
#
# Interps result transmission
#
test interp-26.1 {result code transmission : interp eval direct} {
# Test that all the possibles error codes from Tcl get passed up
# from the child interp's context to the parent, even though the
|
| ︙ | ︙ | |||
2137 2138 2139 2140 2141 2142 2143 |
proc MyTestAlias {interp args} {
global aliasTrace
lappend aliasTrace $args
interp invokehidden $interp {*}$args
}
foreach c {return} {
interp hide $interp $c
| | | 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 |
proc MyTestAlias {interp args} {
global aliasTrace
lappend aliasTrace $args
interp invokehidden $interp {*}$args
}
foreach c {return} {
interp hide $interp $c
interp alias $interp $c {} MyTestAlias $interp $c
}
interp eval $interp {proc ret {code} {return -code $code ret$code}}
set res {}
set aliasTrace {}
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp eval $interp ret $code} msg] $msg
}
|
| ︙ | ︙ | |||
2357 2358 2359 2360 2361 2362 2363 |
test interp-28.1 {getting fooled by child's namespace ?} -setup {
set i [interp create -safe]
proc parent {interp args} {interp hide $interp list}
} -body {
$i alias parent parent $i
set r [interp eval $i {
| | | 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 |
test interp-28.1 {getting fooled by child's namespace ?} -setup {
set i [interp create -safe]
proc parent {interp args} {interp hide $interp list}
} -body {
$i alias parent parent $i
set r [interp eval $i {
namespace eval foo {
proc list {args} {
return "dummy foo::list"
}
parent
}
info commands list
}]
|
| ︙ | ︙ | |||
2547 2548 2549 2550 2551 2552 2553 |
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.4 {recursion limit error reporting} {
interp create child
set r1 [child eval {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 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 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 |
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.4 {recursion limit error reporting} {
interp create child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.5 {recursion limit error reporting} {
interp create child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 4
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.6 {recursion limit error reporting} {
interp create child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 6
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
#
# Note that TEBC does not verify the interp's nesting level itself; the nesting
# level will only be verified when it invokes a non-bcc'd command.
#
test interp-29.3.7a {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.7b {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.7c {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.8a {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.8b {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.9a {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.9b {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.10a {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.10b {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.11a {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.11b {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.12a {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.12b {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
|
| ︙ | ︙ | |||
3007 3008 3009 3010 3011 3012 3013 |
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.9 {safe interpreter recursion limit} {
interp create child -safe
set result [
child eval {
interp create child2 -safe
set n [catch {
| | | | | | | | | | | 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 |
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.9 {safe interpreter recursion limit} {
interp create child -safe
set result [
child eval {
interp create child2 -safe
set n [catch {
interp recursionlimit child2 42
} msg]
list $n $msg
}
]
interp delete child
set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.10 {safe interpreter recursion limit} {
interp create child -safe
set result [
child eval {
interp create child2 -safe
set n [catch {
child2 recursionlimit 42
} msg]
list $n $msg
}
]
interp delete child
set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
# # Deep recursion (into interps when the regular one fails):
|
| ︙ | ︙ | |||
3096 3097 3098 3099 3100 3101 3102 |
lappend parent [pwd]
set i [interp create]
lappend child [$i eval pwd]
cd ..
file delete cwd_test
interp delete $i
expr {[string equal $parent $child] ? 1 :
| | | 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 |
lappend parent [pwd]
set i [interp create]
lappend child [$i eval pwd]
cd ..
file delete cwd_test
interp delete $i
expr {[string equal $parent $child] ? 1 :
"\{$parent\} != \{$child\}"}
} -cleanup {
cd [workingDirectory]
} -result 1
test interp-33.1 {refCounting for target words of alias [Bug 730244]} {
# This test will panic if Bug 730244 is not fixed.
set i [interp create]
|
| ︙ | ︙ | |||
3151 3152 3153 3154 3155 3156 3157 |
proc foobar {} {
while {1} {
# No bytecode at all here...
}
}
}
# We use a time limit here; command limits don't trap this case
| | | | 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 |
proc foobar {} {
while {1} {
# No bytecode at all here...
}
}
}
# We use a time limit here; command limits don't trap this case
$i limit time {*}[_ms_limit_args 50]
$i eval foobar
} -returnCodes error -result {time limit exceeded} -cleanup {
interp delete $i
}
test interp-34.3.1 {basic test of limits - pure inside-command loop} -body {
set i [interp create]
$i eval {
proc foobar {} {
set while while
$while {1} {
# No bytecode at all here...
}
}
}
# We use a time limit here; command limits don't trap this case
$i limit time {*}[_ms_limit_args 50]
$i eval foobar
} -returnCodes error -result {time limit exceeded} -cleanup {
interp delete $i
}
test interp-34.4 {limits with callbacks: extending limits} -setup {
set i [interp create]
set a 0
|
| ︙ | ︙ | |||
3300 3301 3302 3303 3304 3305 3306 |
} -result {4 0} -cleanup {
rename cb3 {}
rename cb4 {}
}
# Bug 1085023
test interp-34.8 {time limits trigger in vwaits} -body {
set i [interp create]
| | | | | | < < > | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > | 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 |
} -result {4 0} -cleanup {
rename cb3 {}
rename cb4 {}
}
# Bug 1085023
test interp-34.8 {time limits trigger in vwaits} -body {
set i [interp create]
interp limit $i time {*}[_ms_limit_args 50] -granularity 1
$i eval {
set x {}
vwait x
}
} -cleanup {
interp delete $i
} -returnCodes error -result {limit exceeded}
test interp-34.9 {time limits trigger in blocking after} {
set i [interp create]
set t0 [clock milliseconds]
interp limit $i time {*}[_ms_limit_args 50 $t0] -granularity 1
set code [catch {
$i eval {after 10000}
} msg]
set t1 [clock milliseconds]
interp delete $i
list $code $msg [expr {($t1-$t0) < 1000 ? "OK" : $t1-$t0}]
} {1 {time limit exceeded} OK}
test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body {
set i [interp create]
interp alias $i log {} lappend result
set result {}
$i limit time {*}[_ms_limit_args 50] -granularity 4
catch {
$i eval {
log 1
after 100
log 2
}
} msg
interp delete $i
lappend result $msg
} -result {1 {time limit exceeded}}
test interp-34.11 {time limit extension in callbacks} -constraints knownBug -setup {
proc cb1 {i args} {
global result
lappend result cb1
$i limit time {*}[_ms_limit_args {*}$args] -command cb2
}
proc cb2 {} {
global result
lappend result cb2
}
} -body {
set i [interp create]
set t0 [clock milliseconds]
$i limit time {*}[_ms_limit_args 50 $t0] \
-command "cb1 $i 100 $t0"
set ::result {}
lappend ::result [catch {
$i eval {
for {set i 0} {$i<30} {incr i} {
after 100
}
}
} msg] $msg
set t1 [clock milliseconds]
lappend ::result [expr {$t1-$t0>=100 ? "ok" : "$t0,$t1"}]
interp delete $i
return $::result
} -result {cb1 cb2 1 {time limit exceeded} ok} -cleanup {
rename cb1 {}
rename cb2 {}
}
test interp-34.12 {time limit extension in callbacks} -setup {
proc cb1 {i t0} {
global result times
lappend result cb1
set times [lassign $times t]
$i limit time {*}[_ms_limit_args $t $t0]
}
} -body {
set i [interp create]
set t0 [clock milliseconds]
set ::times {100 10000}
$i limit time {*}[_ms_limit_args 50] -granularity 1 -command "cb1 $i $t0"
set ::result {}
lappend ::result [catch {
$i eval {
for {set i 0} {$i<5} {incr i} {
after 50
}
}
} msg] $msg
set t1 [clock milliseconds]
lappend ::result [expr {$t1-$t0>=100 ? "ok" : "$t0,$t1"}]
interp delete $i
return $::result
} -result {cb1 cb1 0 {} ok} -cleanup {
rename cb1 {}
}
test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup {
set i [interp create -safe]
} -body {
$i limit time {*}[_ms_limit_args 50]
$i eval {
after 2000 set x timeout
vwait x
return $x
}
} -cleanup {
interp delete $i
} -returnCodes error -result {limit exceeded}
test interp-34.14 {[Bug e3f4a8b78d]: interp limit and interp eval} -setup {
set i [interp create]
set result {}
} -body {
$i limit command -value [$i eval {info cmdcount}] -granularity 1
lappend result [catch {$i eval [list expr 1+3]} msg] $msg
lappend result [catch {$i eval [list expr 1+3]} msg] $msg
lappend result [catch {$i eval {set cmd expr; $cmd 1+3}} msg] $msg
lappend result [catch {$i eval {expr 1+3}} msg] $msg
lappend result [catch {$i eval expr 1+3} msg] $msg
lappend result [catch {interp eval $i [list expr 1+3]} msg] $msg
} -cleanup {
interp delete $i
} -result [lrepeat 6 1 {command count limit exceeded}]
test interp-35.1 {interp limit syntax} -body {
interp limit
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
test interp-35.2 {interp limit syntax} -body {
interp limit {}
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
|
| ︙ | ︙ | |||
3588 3589 3590 3591 3592 3593 3594 |
} -result {foo bar soom}
test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup {
interp create child
child alias handler handler
child bgerror handler
variable result {untouched}
proc handler {args} {
| | | | | | | | 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 |
} -result {foo bar soom}
test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup {
interp create child
child alias handler handler
child bgerror handler
variable result {untouched}
proc handler {args} {
variable result
set result [lindex $args 0]
}
} -body {
child eval {
variable done {}
after 0 error foo
after 10 [list ::set [namespace which -variable done] {}]
vwait [namespace which -variable done]
}
set result
} -cleanup {
variable result {}
unset -nocomplain result
interp delete child
} -result foo
|
| ︙ | ︙ | |||
3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 |
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
# cleanup
unset -nocomplain hidden_cmds
foreach i [interp children] {
interp delete $i
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
| > | 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 |
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
# cleanup
unset -nocomplain hidden_cmds
foreach i [interp children] {
interp delete $i
}
rename _ms_limit_args {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/io.test.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 |
testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}]
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
| | | | | 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 |
testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}]
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
fconfigure $f -translation lf
for { set i 0 } { $i < 100 } { incr i} {
puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
\#"
}
close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
fconfigure $f -translation binary -blocking 0 -eofchar \x1A
fconfigure stdout -translation binary -buffering none
fileevent $f readable "foo $f"
proc foo {f} {
set x [read $f]
catch {puts -nonewline $x}
if {[eof $f]} {
close $f
exit 0
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
| | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f "a\x4D\x00"
close $f
contents $path(test1)
} "a\x4D\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
set sizes
} {19 19 19 19 19}
proc testreadwrite {size {mode ""} args} {
set tmpfile [file join [temporaryDirectory] io-1.10.tmp]
set w [string repeat A $size]
try {
| | | | | | | | | | | | | | | | | | | | | 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 |
set sizes
} {19 19 19 19 19}
proc testreadwrite {size {mode ""} args} {
set tmpfile [file join [temporaryDirectory] io-1.10.tmp]
set w [string repeat A $size]
try {
set fd [open $tmpfile w$mode]
try {
if {[llength $args]} {
fconfigure $fd {*}$args
}
puts -nonewline $fd $w
} finally {
close $fd
}
set fd [open $tmpfile r$mode]
try {
if {[llength $args]} {
fconfigure $fd {*}$args
}
set r [read $fd]
} finally {
close $fd
}
} finally {
file delete $tmpfile
}
string equal $w $r
}
test io-1.10 {WriteChars: large file (> INT_MAX). Bug 3d01d51bc4} -constraints {
pointerIs64bit perf
} -body {
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
testreadwrite 0xffffffff
} -result 1
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
| | | | | < | 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 |
testreadwrite 0xffffffff
} -result 1
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -translation binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-2.2 {WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -translation binary -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-2.3 {WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
set f [open $path(test1) w]
fconfigure $f -translation binary -buffering line -translation crlf
puts -nonewline $f "\n12"
set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -translation binary -buffering line -buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-2.5 {WriteBytes: large file (> INT_MAX). Bug 3d01d51bc4} -constraints {
pointerIs64bit perf
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
puts -nonewline $f "12345678901\n456789012345678901234"
close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
| < | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
puts -nonewline $f "12345678901\n456789012345678901234"
close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.2 {CheckFlush: full} {
set f [open $path(test1) w]
|
| ︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 |
close $f
set x
} "123456789012301234"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
| | | | | | 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 |
close $f
set x
} "123456789012301234"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 16 "123456789012301\x82" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation binary -buffering none
puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
variable x {}
proc ready {f} {
variable x
lappend x [gets $f line] $line [fblocked $f]
}
vwait [namespace which -variable x]
fconfigure $f -translation binary -blocking 1
puts $f "\x51\x82\x52"
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 1 17 "12345678901230123" 0]
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 |
# not (bytesLeft == 0)
set f [open $path(test1) w+]
fconfigure $f -translation binary
puts $f "${a}\r\nabcdef"
close $f
set f [open $path(test1)]
| | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 |
# not (bytesLeft == 0)
set f [open $path(test1) w+]
fconfigure $f -translation binary
puts $f "${a}\r\nabcdef"
close $f
set f [open $path(test1)]
fconfigure $f -translation binary -translation auto
# "${a}\r" was converted in one operation (because ENCODING_LINESIZE
# is 30). To check if "\n" follows, calls PeekAhead and determines
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
test io-11.1 {ReadBytes: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
| | | | | | 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 |
test io-11.1 {ReadBytes: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -translation binary
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-11.2 {ReadBytes: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -translation binary
# here
set x [read $f]
close $f
set x
} {abcdefghijkl}
test io-11.3 {ReadBytes: allocate more space} {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16 -translation binary
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-11.4 {ReadBytes: EOF char found} {
# (TranslateInputEOL() != 0)
set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -translation binary -eofchar m
# here
set x [list [read $f] [eof $f] [read $f] [eof $f]]
close $f
set x
} [list "abcdefghijkl" 1 "" 1]
test io-12.1 {ReadChars: want to read a lot} {
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 |
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} {
# (srcRead == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
| | | | | 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 |
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} {
# (srcRead == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345\x96"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [read $f] [testchannel inputbuffered $f]
}
variable x {}
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
fconfigure $f -translation binary -blocking 1
puts -nonewline $f "\x7B"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "本" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} {
set path(test1) [makeFile {
fconfigure stdout -translation binary -buffering none
gets stdin; puts -nonewline "\xE7"
gets stdin; puts -nonewline "\x89"
gets stdin; puts -nonewline "\xA6"
} test1]
set f [open "|[list [interpreter] $path(test1)]" r+]
fileevent $f readable [namespace code {
lappend x [read $f]
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 |
set t [testchannel type $f]
close $f
string compare $t file
} 0
test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
set f [open $path(test1) w]
| | | 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 |
set t [testchannel type $f]
close $f
string compare $t file
} 0
test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f "1234567890\n098765432"
close $f
set f [open $path(test1) r]
gets $f
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
|
| ︙ | ︙ | |||
2274 2275 2276 2277 2278 2279 2280 |
set s [file size $path(test1)]
close $f
set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
| | | | | | 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 |
set s [file size $path(test1)]
close $f
set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set l ""
puts $f hello
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set l ""
puts $f hello
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
fconfigure $f -buffersize 60
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
{unixOrWin} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
close $f
|
| ︙ | ︙ | |||
2337 2338 2339 2340 2341 2342 2343 |
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {
| | | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 |
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {
fconfigure $f -translation lf -buffering none
while {![eof stdin]} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
}
close $f
|
| ︙ | ︙ | |||
2404 2405 2406 2407 2408 2409 2410 |
test io-28.3 {CloseChannel, not called before output queue is empty} \
{stdio asyncPipeClose nonPortable} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f {
| < < < < < < < | | 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 |
test io-28.3 {CloseChannel, not called before output queue is empty} \
{stdio asyncPipeClose nonPortable} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f {
set f [open $path(output) w]
fconfigure $f -translation lf -buffering none
for {set x 0} {$x < 20} {incr x} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] pipe]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 20480) && ($counter < 1000)} {
after 20 [list incr [namespace which -variable counter]]
vwait [namespace which -variable counter]
|
| ︙ | ︙ | |||
2475 2476 2477 2478 2479 2480 2481 |
test io-28.6 {
close channel in write event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
| | > > | > > > > > > > | > > > > > | > > | < | > > | | | | | < < | | | | | 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 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 |
test io-28.6 {
close channel in write event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
} -body {
variable done
variable res
# Not a complete / correct channel implementation. Just enough
# to exercise the crash - closing from a write handler
after 0 [list coroutine c1 apply [list {} {
variable done
set chan [chan create w {apply {{cmd chan args} {
switch $cmd {
blocking - finalize {
}
watch {
lappend ::timers286 [after 0 chan postevent $chan write]
}
initialize {
list initialize finalize watch read write configure blocking
}
default {
error [list {unexpected command} $cmd]
}
}
}}}]
chan configure $chan -blocking 0
while 1 {
chan event $chan writable [list [info coroutine]]
yield
close $chan
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
return success
} -cleanup {
foreach timer $::timers286 {after cancel $timer}
} -result success
test io-28.7 {
close channel in read event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
} -body {
variable done
variable res
after 0 [list coroutine c1 apply [list {} {
variable done
# Not a complete / correct channel implementation. Just enough
# to exercise the crash - closing from a read handler
set chan [chan create r {apply {{cmd chan args} {
switch $cmd {
blocking - finalize {
}
watch {
lappend ::timers287 [after 0 chan postevent $chan read]
}
initialize {
list initialize finalize watch read write configure blocking
}
default {
error [list {unexpected command} $cmd]
}
}
}}}]
chan configure $chan -blocking 0
while 1 {
chan event $chan readable [list [info coroutine]]
yield
close $chan
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
return success
} -cleanup {
foreach timer $::timers287 {after cancel $timer}
} -result success
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
file delete $path(test1)
set f [open $path(test1) w]
puts -nonewline $f ""
close $f
file size $path(test1)
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
file delete $path(test1)
set f [open $path(test1) w]
puts -nonewline $f hello
close $f
file size $path(test1)
} 5
test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {6 0 0 6}
test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 11}
test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering none
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {0 5 0 11}
test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
2641 2642 2643 2644 2645 2646 2647 |
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
file delete $path(test1)
set f1 [open $path(test1) w]
| | < | 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 |
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts $f1 [gets $f2]
}
close $f2
close $f1
file size $path(test1)
} 387
test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
file delete $path(test1)
set f1 [open $path(test1) w]
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
|
| ︙ | ︙ | |||
2779 2780 2781 2782 2783 2784 2785 |
lappend x [file size $path(test1)]
close $f1
set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
| | | | 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 |
lappend x [file size $path(test1)]
close $f1
set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
set x ""
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
close $f1
lappend x [file size $path(test1)]
set x
} {18 24 30}
test io-29.20 {Implicit flush when buffer is full} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
set z ""
lappend z [file size $path(test1)]
for {set x 0} {$x < 100} {incr x} {
|
| ︙ | ︙ | |||
2935 2936 2937 2938 2939 2940 2941 |
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
| | | | | 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 |
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
flush $f
set s [file size $path(test1)]
close $f
set s
} 21
test io-29.29 {Tcl_WriteChars, cr mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 21
test io-29.30 {Tcl_WriteChars, crlf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} stdio {
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
|
| ︙ | ︙ | |||
3527 3528 3529 3530 3531 3532 3533 |
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
| | | | | | | | 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 |
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1Aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {0 1 {} 1}
test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
|
| ︙ | ︙ | |||
4063 4064 4065 4066 4067 4068 4069 |
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
| | | | | | | | 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 4127 4128 4129 4130 4131 |
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1Aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1Aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
|
| ︙ | ︙ | |||
4165 4166 4167 4168 4169 4170 4171 |
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
| | | | | | 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 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 |
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l ""
lappend l [gets $f]
|
| ︙ | ︙ | |||
4588 4589 4590 4591 4592 4593 4594 |
set f [open $path(test3) r]
set result [list [catch {gets $f x(0)} msg] $msg]
close $f
set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
| | | | | 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 |
set f [open $path(test3) r]
set result [list [catch {gets $f x(0)} msg] $msg]
close $f
set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 100} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 100} {incr y} {gets $f}
close $f
set y
} 100
test io-33.9 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 200} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 200} {incr y} {gets $f}
close $f
set y
} 200
test io-33.10 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 300} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 300} {incr y} {gets $f}
|
| ︙ | ︙ | |||
4742 4743 4744 4745 4746 4747 4748 |
set c [tell $f1]
close $f1
set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
file delete $path(test1)
set f1 [open $path(test1) w]
| | | | | | | | 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 |
set c [tell $f1]
close $f1
set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c [tell $f1]
close $f1
set c
} 10
test io-34.3 {Tcl_Seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c [tell $f1]
close $f1
set c
} 54
test io-34.4 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
close $f1
set c
} 44
test io-34.5 {Tcl_Seek to offset from current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 current
seek $f1 10 current
set c [tell $f1]
close $f1
set c
} 20
test io-34.6 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
set r [read $f1]
close $f1
list $c $r
} {44 {rstuvwxyz
}}
test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c1 [tell $f1]
set r1 [read $f1 5]
|
| ︙ | ︙ | |||
4833 4834 4835 4836 4837 4838 4839 |
close $f1
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
file delete $path(test3)
set f [open $path(test3) w]
| < | 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 |
close $f1
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
set f [open $path(test3) RDWR]
set x [read $f 1]
seek $f 3
lappend x [read $f 1]
seek $f 0 start
|
| ︙ | ︙ | |||
4881 4882 4883 4884 4885 4886 4887 |
seek $f 2
set x [gets $f]
close $f
list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
| | | | | | 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 4929 4930 4931 4932 4933 4934 4935 4936 4937 |
seek $f 2
set x [gets $f]
close $f
list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyz\n123
close $f
set f [open $path(test3) a+]
fconfigure $f -translation lf
puts $f xyzzy
flush $f
set x [tell $f]
seek $f -4 cur
set y [gets $f]
close $f
list $x [viewFile test3] $y
} {14 {xyz
123
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
set p [tell $f1]
close $f1
set p
} 0
test io-34.14 {Tcl_Tell after seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c1 [tell $f1]
close $f1
set c1
} 54
test io-34.15 {Tcl_Tell combined with seeking} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
|
| ︙ | ︙ | |||
4949 4950 4951 4952 4953 4954 4955 |
gets $f1
close $f1
set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
file delete $path(test2)
set f [open $path(test2) w]
| | | | 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 |
gets $f1
close $f1
set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
file delete $path(test2)
set f [open $path(test2) w]
fconfigure $f -translation lf
puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
close $f
set f [open $path(test2)]
fconfigure $f -translation lf
set x [tell $f]
read $f 3
lappend x [tell $f]
seek $f 2
lappend x [tell $f]
seek $f 10 current
lappend x [tell $f]
seek $f 0 end
lappend x [tell $f]
close $f
set x
} {0 3 2 12 30}
test io-34.19 {Tcl_Tell combined with opening in append mode} {
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f "abcdefghijklmnopqrstuvwxyz"
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
set f [open $path(test3) a]
set c [tell $f]
close $f
set c
|
| ︙ | ︙ | |||
4992 4993 4994 4995 4996 4997 4998 |
puts -nonewline $f a
lappend l [tell $f]
seek $f 407 end
lappend l [tell $f]
close $f
set l
} {29 39 40 447}
| | | | 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 |
puts -nonewline $f a
lappend l [tell $f]
seek $f 407 end
lappend l [tell $f]
close $f
set l
} {29 39 40 447}
test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport extensive} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -translation binary
set l ""
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
flush $f
lappend l [tell $f]
# 4GB offset!
|
| ︙ | ︙ | |||
5189 5190 5191 5192 5193 5194 5195 |
set e [eof $f]
close $f
list $s $l $e
} {10 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
| | | | | | | | 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 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 |
set e [eof $f]
close $f
list $s $l $e
} {10 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [read $f]]
|
| ︙ | ︙ | |||
5335 5336 5337 5338 5339 5340 5341 |
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {1 1 1 13}
test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
| | | | 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 |
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {1 1 1 13}
test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
list $c $l $e [scan [string index $in end] %c]
} -result {17 8 1 13}
test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format \n%cqrsuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [set in [read $f]]]
|
| ︙ | ︙ | |||
5386 5387 5388 5389 5390 5391 5392 |
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
| | | | 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 |
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
chan configure $f1 -translation binary
puts $f1 {
chan configure stdout -translation binary
puts hello_from_pipe
}
flush $f1
gets $f1
fconfigure $f1 -blocking off -buffering full
puts $f1 {puts hello}
set x ""
|
| ︙ | ︙ | |||
5636 5637 5638 5639 5640 5641 5642 |
close $f1
set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
| | | 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 |
close $f1
set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
fconfigure $f1 -translation lf -buffering none
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
fconfigure $f1 -buffering full
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
5731 5732 5733 5734 5735 5736 5737 |
set x [fconfigure $f -buffersize]
close $f
set x
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
| | | | 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 |
set x [fconfigure $f -buffersize]
close $f
set x
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f \xE7\x89\xA6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
} 牦
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f \xE7\x89\xA6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
|
| ︙ | ︙ | |||
5768 5769 5770 5771 5772 5773 5774 |
set f [open $path(test1) w]
fconfigure $f -e foobar
} -cleanup {
close $f
} -returnCodes 1 -match glob -result {bad option "-e": should be one of *}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" r+]
| | | | 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 |
set f [open $path(test1) w]
fconfigure $f -e foobar
} -cleanup {
close $f
} -returnCodes 1 -match glob -result {bad option "-e": should be one of *}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" r+]
fconfigure $f -encoding iso8859-1
puts -nonewline $f "\xE7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
variable x {}
fileevent $f readable [namespace code { lappend x [read $f] }]
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
fconfigure $f -encoding utf-8
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
fconfigure $f -translation binary
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
close $f
set x
} "{} timeout {} timeout \xE7 timeout"
test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \
|
| ︙ | ︙ | |||
5920 5921 5922 5923 5924 5925 5926 |
close $f
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode)&0o777}]
} [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
| < < | | 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 |
close $f
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode)&0o777}]
} [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY CREAT}]
puts -nonewline $f "ab"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abzzy
test io-40.5 {POSIX open access modes: APPEND} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY APPEND}]
fconfigure $f -translation lf
puts $f "new line"
seek $f 0
puts $f "abc"
|
| ︙ | ︙ | |||
5963 5964 5965 5966 5967 5968 5969 |
puts $f xyzzy
close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test io-40.7 {POSIX open access modes: EXCL} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT EXCL}]
| < | 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 |
puts $f xyzzy
close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test io-40.7 {POSIX open access modes: EXCL} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT EXCL}]
puts $f "A test line"
close $f
viewFile test3
} {A test line}
test io-40.8 {POSIX open access modes: TRUNC} {
file delete $path(test3)
set f [open $path(test3) w]
|
| ︙ | ︙ | |||
6014 6015 6016 6017 6018 6019 6020 |
test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.13 {POSIX open access modes: WRONLY} {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
| < | 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 |
test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.13 {POSIX open access modes: WRONLY} {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
lappend x [viewFile test3]
string compare [string tolower $x] \
[list 1 "channel \"$f\" wasn't opened for reading" abzzy]
|
| ︙ | ︙ | |||
6053 6054 6055 6056 6057 6058 6059 |
set x [list [catch {open ~/foo} msg] $msg]
set ::env(HOME) $home
set x
} {1 {couldn't open "~/foo": no such file or directory}}
test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo} msg] $msg
| | | | 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 |
set x [list [catch {open ~/foo} msg] $msg]
set ::env(HOME) $home
set x
} {1 {couldn't open "~/foo": no such file or directory}}
test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channel event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo bar baz q} msg] $msg
} {1 {wrong # args: should be "fileevent channel event ?script?"}}
test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp readable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp writable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {
|
| ︙ | ︙ | |||
6232 6233 6234 6235 6236 6237 6238 6239 |
set x
} -cleanup {
close $f4
} -result {initial foo eof}
close $f
test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
| > > > | | > > > | < > > > | > > | > > > > > > > > > > > > > > > > | < | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 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 |
set x
} -cleanup {
close $f4
} -result {initial foo eof}
close $f
# Bug https://core.tcl-lang.org/tcl/info/de232b49f26da1c1 with a corrected
# refchan implementation. refchans should be responsible for their own
# event generation and the one in the bug report was not doing so.
test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio fileevent} -body {
namespace eval refchan {
namespace ensemble create
namespace export *
# Change to taste depending on how much CPU you want to hog
variable delay 0
proc finalize {chan args} {
namespace upvar c_$chan timer timer
catch {after cancel $timer}
namespace delete c_$chan
}
proc initialize {chan args} {
namespace eval c_$chan {}
namespace upvar c_$chan watching watching timer timer
set watching {}
list finalize initialize seek watch write
}
proc watch {chan args} {
namespace upvar c_$chan watching watching
foreach arg $args {
switch $arg {
write {
if {$arg ni $watching} {
lappend watching $arg
}
}
}
}
update $chan
}
proc write {chan args} {
return 1
}
# paraphrased from tcllib
proc update {chan} {
namespace upvar c_$chan watching watching timer timer
variable delay
catch {after cancel $timer}
if {"write" in $watching} {
set timer [after idle after $delay \
[namespace code [list post $chan]]]
}
}
# paraphrased from tcllib
proc post {chan} {
variable delay
namespace upvar c_$chan watching watching timer timer
if {"write" in $watching} {
set timer [after idle after $delay \
[namespace code [list post $chan]]]
chan postevent $chan write
}
}
}
set f [chan create w [namespace which refchan]]
chan configure $f -blocking 0
set data "some data"
set x 0
chan event $f writable [namespace code {
puts $f $data
incr count [string length $data]
if {$count > 262144} {
chan event $f writable {}
set x done
}
}]
# Note: timeout needs to be very long under valgrind
set token [after 240000 [namespace code {
set x timeout
}]]
vwait [namespace which -variable x]
return $x
} -cleanup {
after cancel $token
catch {chan close $f}
} -result done
# Bug https://core.tcl-lang.org/tcl/info/67a5eabbd3d1 with a corrected
# refchan implementation. refchans that are not reentrant should use
# event loop to post events and the script in the bug report was not
# doing so.
test io-44.7 {refchan + coroutine yield error } -setup {
set bghandler [interp bgerror {}]
namespace eval schan {
namespace ensemble create
namespace export *
proc open {} {
set chan [chan create read [namespace current]]
}
proc initialize {chan mode} {
return [list initialize finalize read watch]
}
proc finalize args {}
proc read {chan count} {}
proc watch {chan eventspec} {
foreach event $eventspec {
after idle after 0 chan postevent $chan $event
}
}
}
} -cleanup {
interp bgerror {} $bghandler
unset -nocomplain ::io-44.7-result
namespace delete schan
} -body {
interp bgerror {} [list apply {{res opts} {
set ::io-44.7-result [dict get $opts -errorinfo]
}}]
coroutine c1 apply [list {} {
set chan [schan::open]
chan event $chan readable [list [info coroutine]]
yield
close $chan
set ::io-44.7-result success
} [namespace current]]
vwait ::io-44.7-result
set ::io-44.7-result
} -result success
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
|
| ︙ | ︙ | |||
7515 7516 7517 7518 7519 7520 7521 |
[file size $path(utf8-rp.txt)]
} {3 5 5}
test io-52.10 {TclCopyChannel & encodings} -constraints fcopy -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
| < < | 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 |
[file size $path(utf8-rp.txt)]
} {3 5 5}
test io-52.10 {TclCopyChannel & encodings} -constraints fcopy -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -translation binary
fcopy $in $out
file size $path(utf8-fcopy.txt)
} -cleanup {
close $in
close $out
} -returnCodes 1 -match glob -result {error writing "*":\
invalid or incomplete multibyte or wide character}
test io-52.11 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf -profile strict
puts $out АА
close $out
} -constraints {fcopy} -body {
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
fconfigure $in -translation binary
fconfigure $out -encoding koi8-r -translation lf -profile strict
catch {fcopy $in $out} cres copts
return $cres
} -cleanup {
if {$in in [chan names]} {
close $in
|
| ︙ | ︙ | |||
8296 8297 8298 8299 8300 8301 8302 |
puts stderr 2COPY
}
puts stderr ...
}
puts stderr SRV
set l {}
set srv [socket -server new -myaddr 127.0.0.1 0]
| | | 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 |
puts stderr 2COPY
}
puts stderr ...
}
puts stderr SRV
set l {}
set srv [socket -server new -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
puts stderr WAITING
fileevent stdin readable bye
puts "OK $port"
vwait forever
}
# wait for OK from server.
lassign [gets $pipe] ok port
|
| ︙ | ︙ | |||
9240 9241 9242 9243 9244 9245 9246 |
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
test io-75.1 {multibyte encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.1]
set f [open $fn w+]
| | | 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 |
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
test io-75.1 {multibyte encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.1]
set f [open $fn w+]
fconfigure $f -translation binary
# In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed
# by a byte > 0x7F. This is violated to get an invalid sequence.
puts -nonewline $f A\xC0\x40
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -profile tcl8 -buffering none
} -body {
|
| ︙ | ︙ | |||
9276 9277 9278 9279 9280 9281 9282 |
# Incomplete sequence test.
# This error may IMHO only be detected with the close.
# But the read already returns the incomplete sequence.
test io-75.3 {incomplete multibyte encoding read is ignored (-profile tcl8)} -setup {
set fn [makeFile {} io-75.3]
set f [open $fn w+]
| | | | | | | | | | | | | | | | | | | 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 9525 9526 9527 9528 9529 |
# Incomplete sequence test.
# This error may IMHO only be detected with the close.
# But the read already returns the incomplete sequence.
test io-75.3 {incomplete multibyte encoding read is ignored (-profile tcl8)} -setup {
set fn [makeFile {} io-75.3]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f "A\xC0"
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -profile tcl8
} -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.3
} -result 41c0
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.4 {shiftjis encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.4]
set f [open $fn w+]
fconfigure $f -translation binary
# In shiftjis, \x81 starts a two-byte sequence.
# But 2nd byte \xFF is not allowed
puts -nonewline $f A\x81\xFFA
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -profile tcl8
} -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.4
} -result 4181ff41
test io-75.5 {invalid utf-8 encoding read is ignored (-profile tcl8)} -setup {
set fn [makeFile {} io-75.5]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -profile tcl8
} -body {
set d [read $f]
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 -translation 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 \
-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 -translation 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 \
-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 -translation 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 \
-translation lf -profile strict
} -body {
set l {}
lappend l [catch {gets $f}]
lappend l [tell $f]
fconfigure $f -translation 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 -translation 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 \
-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 -translation 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 \
-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 -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -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 -translation 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
|
| ︙ | ︙ | |||
9472 9473 9474 9475 9476 9477 9478 |
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.
| | | 9539 9540 9541 9542 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 9553 |
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 -translation 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 {
|
| ︙ | ︙ | |||
9499 9500 9501 9502 9503 9504 9505 |
test io-strict-multibyte-eof {
incomplete utf-8 sequence immediately prior to eof character
See issue 25cdcb7e8fb381fb
} -setup {
set chan [file tempfile];
| | | 9566 9567 9568 9569 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 |
test io-strict-multibyte-eof {
incomplete utf-8 sequence immediately prior to eof character
See issue 25cdcb7e8fb381fb
} -setup {
set chan [file tempfile];
fconfigure $chan -translation 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 {
|
| ︙ | ︙ | |||
9535 9536 9537 9538 9539 9540 9541 |
test io-75.10 {
incomplete multibyte encoding read is not ignored because "binary" sets
profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.10]
set f [open $fn w+]
| | | 9602 9603 9604 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 |
test io-75.10 {
incomplete multibyte encoding read is not ignored because "binary" sets
profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.10]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\xC0
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none
} -body {
catch {read $f} errmsg
lappend res $errmsg
|
| ︙ | ︙ | |||
9564 9565 9566 9567 9568 9569 9570 |
# This may be expected due to special utf-8 handling.
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.11 {shiftjis encoding error read results in error (strict profile)} -setup {
set fn [makeFile {} io-75.11]
set f [open $fn w+]
| | | | | | 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 |
# This may be expected due to special utf-8 handling.
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.11 {shiftjis encoding error read results in error (strict profile)} -setup {
set fn [makeFile {} io-75.11]
set f [open $fn w+]
fconfigure $f -translation binary
# In shiftjis, \x81 starts a two-byte sequence.
# But 2nd byte \xFF is not allowed
puts -nonewline $f A\x81\xFFA
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -blocking 0 -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]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -translation lf
} -body {
catch {read $f} errmsg
lappend res $errmsg
chan configure $f -profile tcl8
seek $f 0
set d [read $f]
binary scan $d H* hd
|
| ︙ | ︙ | |||
9617 9618 9619 9620 9621 9622 9623 |
test io-75.13 {
In nonblocking mode when there is an encoding error the data that has been
successfully read so far is returned first and then the error is returned
on the next call to [read].
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
| | | | | | 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 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 9721 9722 9723 9724 9725 9726 9727 |
test io-75.13 {
In nonblocking mode when there is an encoding error the data that has been
successfully read so far is returned first and then the error is returned
on the next call to [read].
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -blocking 0 -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 -translation 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 \
-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]
|
| ︙ | ︙ | |||
9669 9670 9671 9672 9673 9674 9675 |
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]
| | | 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 |
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 -translation 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]
|
| ︙ | ︙ | |||
9825 9826 9827 9828 9829 9830 9831 |
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 {
| | | | | | | | 9892 9893 9894 9895 9896 9897 9898 9899 9900 9901 9902 9903 9904 9905 9906 9907 9908 9909 9910 9911 9912 9913 9914 9915 9916 9917 9918 9919 9920 9921 9922 |
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
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
#----------------------------------------------------------------------
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
| | | | | | | | | | | | | | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 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 |
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
#----------------------------------------------------------------------
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}}
test iocmd-1.2 {puts command} {
list [catch {puts a b c d e f g} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}}
test iocmd-1.3 {puts command} {
list [catch {puts froboz -nonewline kablooie} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}}
test iocmd-1.4 {puts command} {
list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
test iocmd-1.5 {puts command} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
set path(test1) [makeFile {} test1]
test iocmd-1.6 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f foobar
close $f
file size $path(test1)
} 6
test iocmd-1.7 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f foobar
close $f
file size $path(test1)
} 7
test iocmd-1.8 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [binary format a4a5 foo bar]
close $f
file size $path(test1)
} 9
test iocmd-2.1 {flush command} {
list [catch {flush} msg] $msg
} {1 {wrong # args: should be "flush channel"}}
test iocmd-2.2 {flush command} {
list [catch {flush a b c d e} msg] $msg
} {1 {wrong # args: should be "flush channel"}}
test iocmd-2.3 {flush command} {
list [catch {flush foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-2.4 {flush command} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test iocmd-3.1 {gets command} {
list [catch {gets} msg] $msg
} {1 {wrong # args: should be "gets channel ?varName?"}}
test iocmd-3.2 {gets command} {
list [catch {gets a b c d e f g} msg] $msg
} {1 {wrong # args: should be "gets channel ?varName?"}}
test iocmd-3.3 {gets command} {
list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
set f [open $path(test1) w]
puts $f [binary format a4a5 foo bar]
close $f
set f [open $path(test1) r]
set result [gets $f]
close $f
set x foo\x00
set x "${x}bar\x00\x00"
string compare $x $result
} 0
test iocmd-4.1 {read command} {
list [catch {read} msg] $msg
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}}
test iocmd-4.2 {read command} {
list [catch {read a b c d e f g h} msg] $msg
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}}
test iocmd-4.3 {read command} {
list [catch {read aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-4.4 {read command} {
list [catch {read -nonewline} msg] $msg
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}}
test iocmd-4.5 {read command} {
list [catch {read -nonew file4} msg] $msg $::errorCode
} {1 {can not find channel named "-nonew"} {TCL LOOKUP CHANNEL -nonew}}
test iocmd-4.6 {read command} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode]
close $f
set x
} {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"} {TCL WRONGARGS}}
test iocmd-4.9 {read command} {
list [catch {read stdin foo} msg] $msg $::errorCode
} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}}
test iocmd-4.10 {read command} {
list [catch {read file107} msg] $msg $::errorCode
} {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}}
set path(test3) [makeFile {} test3]
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
read $f 12z
} -cleanup {
close $f
} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
| | | | | | | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
read $f 12z
} -cleanup {
close $f
} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
} -result {wrong # args: should be "seek channel offset ?origin?"}
test iocmd-5.2 {seek command} -returnCodes error -body {
seek a b c d e f g
} -result {wrong # args: should be "seek channel offset ?origin?"}
test iocmd-5.3 {seek command} -returnCodes error -body {
seek stdin gugu
} -result {expected integer but got "gugu"}
test iocmd-5.4 {seek command} -returnCodes error -body {
seek stdin 100 gugu
} -result {bad origin "gugu": must be start, current, or end}
test iocmd-6.1 {tell command} {
list [catch {tell} msg] $msg
} {1 {wrong # args: should be "tell channel"}}
test iocmd-6.2 {tell command} {
list [catch {tell a b c d e} msg] $msg
} {1 {wrong # args: should be "tell channel"}}
test iocmd-6.3 {tell command} {
list [catch {tell aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-7.1 {close command} {
list [catch {close} msg] $msg
} {1 {wrong # args: should be "close channel ?direction?"}}
test iocmd-7.2 {close command} {
list [catch {close a b c d e} msg] $msg
} {1 {wrong # args: should be "close channel ?direction?"}}
test iocmd-7.3 {close command} {
list [catch {close aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-7.4 {close command} -setup {
set chan [open [info script] r]
} -body {
chan close $chan bar
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
}
set opts [list {*}$basicOpts {*}$extra]
lset opts end [string cat "or " [lindex $opts end]]
return [format {bad option "%s": should be one of %s} $got [join $opts ", "]]
}
test iocmd-8.1 {fconfigure command} -returnCodes error -body {
fconfigure
| | | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
}
set opts [list {*}$basicOpts {*}$extra]
lset opts end [string cat "or " [lindex $opts end]]
return [format {bad option "%s": should be one of %s} $got [join $opts ", "]]
}
test iocmd-8.1 {fconfigure command} -returnCodes error -body {
fconfigure
} -result {wrong # args: should be "fconfigure channel ?-option value ...?"}
test iocmd-8.2 {fconfigure command} -returnCodes error -body {
fconfigure a b c d e f
} -result {wrong # args: should be "fconfigure channel ?-option value ...?"}
test iocmd-8.3 {fconfigure command} -returnCodes error -body {
fconfigure a b
} -result {can not find channel named "a"}
test iocmd-8.4 {fconfigure command} -setup {
file delete $path(test1)
set f1 [open $path(test1) w]
} -body {
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | < | 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 |
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding utf-16
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile strict -translation lf}
test iocmd-8.8 {fconfigure command} -setup {
file delete $path(test1)
set x {}
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-encoding utf-16 -profile tcl8
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
} -cleanup {
catch {close $f1}
} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf}}
test iocmd-8.9 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering none -buffersize 4040 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}
test iocmd-8.10 {fconfigure command} -returnCodes error -body {
fconfigure a b
} -result {can not find channel named "a"}
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
test iocmd-8.23 {fconfigure -profile badprofile} -body {
fconfigure stdin -profile froboz
} -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8}
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $::errorCode
| | | | | | 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 |
test iocmd-8.23 {fconfigure -profile badprofile} -body {
fconfigure stdin -profile froboz
} -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8}
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channel"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
list [catch {eof a b} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channel"} {TCL WRONGARGS}}
test iocmd-9.3 {eof command} {
catch {close file100}
list [catch {eof file100} msg] $msg $::errorCode
} {1 {can not find channel named "file100"} {TCL LOOKUP CHANNEL file100}}
# The tests for Tcl_ExecObjCmd are in exec.test
test iocmd-10.1 {fblocked command} {
list [catch {fblocked} msg] $msg
} {1 {wrong # args: should be "fblocked channel"}}
test iocmd-10.2 {fblocked command} {
list [catch {fblocked a b c d e f g} msg] $msg
} {1 {wrong # args: should be "fblocked channel"}}
test iocmd-10.3 {fblocked command} {
list [catch {fblocked file1000} msg] $msg
} {1 {can not find channel named "file1000"}}
test iocmd-10.4 {fblocked command} {
list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unix} {
file delete $path(test3)
set f [open $path(test3) w]
| < < < | | | | | > > > > > > > > > | 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 |
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unix} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) WRONLY]
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy]
string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test iocmd-12.6 {POSIX open access modes: errors} {
concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$::errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
while processing open access modes \"FOO {BAR BAZ\"
invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, RDONLY, RDWR, TRUNC, or WRONLY}}
test iocmd-12.8 {POSIX open access modes: errors} {
list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, RDWR, or WRONLY}}
close [open $path(test3) w]
test iocmd-12.9 {POSIX open access modes: BINARY} {
list [catch {open $path(test1) BINARY} msg] $msg
} {1 {access mode must include either RDONLY, RDWR, or WRONLY}}
test iocmd-12.10 {POSIX open access modes: BINARY} {
set f [open $path(test1) {WRONLY BINARY TRUNC}]
puts $f a
puts $f b
puts -nonewline $f c ;# contents are now 5 bytes: a\nb\nc
close $f
set f [open $path(test1) r]
fconfigure $f -translation binary
set result [string length [read $f]]
close $f
set result
} 5
test iocmd-12.10.1 {POSIX open access modes: BINARY} -body {
after 100
set f [open $path(test1) {WRONLY BINARY TRUNC}]
puts $f Ɉ ;# throws an exception
} -cleanup {
close $f
} -returnCodes 1 -match glob -result {error writing "*": invalid or incomplete multibyte or wide character}
test iocmd-12.11 {POSIX open access modes: BINARY} {
set f [open $path(test1) {WRONLY BINARY TRUNC}]
puts $f H
close $f
set f [open $path(test1) r]
fconfigure $f -translation binary
set result [read -nonewline $f]
close $f
set result
} H
test iocmd-12.12 {POSIX open access modes: errors} {
list [catch {open $path(test3) {RDWR WRONLY}} msg] $msg
} {1 {invalid access mode "WRONLY": modes RDONLY, RDWR, and WRONLY cannot be combined}}
test iocmd-12.13 {POSIX open access modes: errors} {
list [catch {open $path(test3) {BINARY BINARY}} msg] $msg
} {1 {access mode "BINARY" repeated}}
test iocmd-12.14 {POSIX open access modes: errors} {
list [catch {open $path(test3) {TRUNC}} msg] $msg
} {1 {access mode must include either RDONLY, RDWR, or WRONLY}}
test iocmd-13.1 {errors in open command} {
list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
|
| ︙ | ︙ | |||
958 959 960 961 962 963 964 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
| < < < < < < < < < < < | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
}
# Set everything up in the main thread.
eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 |
set res {}
proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
| | | | | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
set res {}
proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *}}}
test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
proc foo args {oninit cget cgetall; onfinal; track; return ""}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *}}}
test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
proc foo args {
oninit cget cgetall; onfinal; track
return {-bar foo -snarf x}
}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *} -bar foo -snarf x}}
test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
set res {}
proc foo {args} {
oninit cget cgetall; onfinal; track
return "-bar"
}
set c [chan create {r w} foo]
|
| ︙ | ︙ | |||
2050 2051 2052 2053 2054 2055 2056 |
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
| | | < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* read} {} TOCK {} {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
note [fileevent $c writable {lappend res TOCK; set tock 1}]
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c w]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* write} {} TOCK {} {watch rc* {}}}
test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
proc foo {args} {oninit; onfinal; track; return}
proc dummy args { return }
set c [chan create {r w} foo]
fileevent $c readable dummy
} -body {
close $c
chan postevent $c read
} -cleanup {
rename foo {}
rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to
# other interpreter B, destroy the origin interpreter (A) before or
# during access from B. Must not crash, must return proper errors.
test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
|
| ︙ | ︙ | |||
2194 2195 2196 2197 2198 2199 2200 |
test iocmd-32.2 {delete interp of reflected chan} {
# Bug 3034840
# Run this test in an interp with memory debugging to panic
# on the double free
interp create child
child eval {
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
test iocmd-32.2 {delete interp of reflected chan} {
# Bug 3034840
# Run this test in an interp with memory debugging to panic
# on the double free
interp create child
child eval {
proc no-op args {}
proc driver {sub args} {return {initialize finalize watch read}}
chan event [chan create read driver] readable no-op
}
interp delete child
} {}
# 1st attempt without error in write, another with error in write:
foreach ::writeErr {0 1} {
test iocmd-32.3.$::writeErr {prevent copy-state against segfault by finalize, bug [79474c58800cdf94]} -setup {
proc test_chan {args} {
set rest [lassign $args mode chan]
lappend ::ret $mode
switch -exact $mode {
read {puts $chan "Test" ; close $chan}
write {if {$::writeErr} {return "boom"}; set data [lindex $rest 0]; string length $data}
finalize {after 20 {set ::done done}}
initialize {return "initialize watch finalize read write"}
}
}
set clchlst {}
set toev [after 5000 {set ::done tout}]
} -body {
set ::ret {}
set ch [chan create "read write" test_chan]
lappend clchlst $ch
lassign [chan pipe] in1 out1
lappend clchlst $in1 $out1
lassign [chan pipe] in2 out2
lappend clchlst $in2 $out2
lassign [chan pipe] in3 out3
lappend clchlst $in3 $out3
# simulate exec: echo test >@ $out2 2>@ $out3 <@ $in1 &:
fileevent $out2 writable [list apply {{cho che} {
puts $cho test; close $cho; close $che
}} $out2 $out3]
# recopy to given chans in handler
fileevent $in2 readable [list apply {{in out} {
if {[catch {
chan copy $in $out
} msg]} {
#puts err:$msg
fileevent $in readable {}
}
}} $in2 $ch]
fileevent $in3 readable [list apply {{in out} {
if {[catch {
chan copy $in $out
} msg]} {
#puts err:$msg
fileevent $in readable {}
}
}} $in3 $ch]
fileevent $out1 writable [list apply {{in out} {
if {[catch {
chan copy $in $out
} msg]} {
#puts err:$msg
fileevent $out writable {}
}
}} $ch $out1]
vwait ::done
lappend ::ret $::done
} -cleanup {
foreach ch $clchlst {
catch {close $ch}
}
after cancel $toev
unset -nocomplain ::done ::ret ch in1 in2 in3 out1 out2 out3 toev clchlst
} -result {initialize read write finalize done}
}; unset ::writeErr
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.
# -*- tcl -*-
# ### ### ### ######### ######### #########
|
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 |
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
| | | | | 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 |
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
-result {{-blocking 1 -buffering full -buffersize 4096 -encoding * * -translation {auto *}}}
test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
proc foo {args} {oninit cget cgetall; onfinal; track; return ""}
set c [chan create {r w} foo]
notes [inthread $c {
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
-result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * * -translation {auto *}}}
test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
proc foo {args} {
oninit cget cgetall; onfinal; track
return "-bar foo -snarf x"
}
set c [chan create {r w} foo]
notes [inthread $c {
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
-result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * * -translation {auto *} -bar foo -snarf x}}
test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
set res {}
proc foo {args} {
oninit cget cgetall; onfinal; track
return "-bar"
}
set c [chan create {r w} foo]
|
| ︙ | ︙ | |||
4026 4027 4028 4029 4030 4031 4032 |
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}
| | | 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 |
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 {
|
| ︙ | ︙ | |||
4084 4085 4086 4087 4088 4089 4090 |
} -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 {
| | | 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 |
} -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
|
| ︙ | ︙ |
Changes to tests/ioTrans.test.
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
rename foo {}
} -result {{read rt* {test data
}} {}}
# Driver for a base channel that emits several short "files"
# with each terminated by a fleeting EOF
proc driver {cmd args} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
rename foo {}
} -result {{read rt* {test data
}} {}}
# Driver for a base channel that emits several short "files"
# with each terminated by a fleeting EOF
proc driver {cmd args} {
variable ::tcl::buffer
variable ::tcl::index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) .....
return {initialize finalize watch read}
}
finalize {
if {![info exists index($chan)]} {return}
unset index($chan) buffer($chan)
array unset index
array unset buffer
return
}
watch {}
read {
set n [lindex $args 1]
if {![info exists index($chan)]} {
driver initialize $chan
}
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
if {[string length $result] == 0} {
driver finalize $chan
}
return $result
}
}
}
namespace eval reflector {
proc initialize {_ chan mode} {
return {initialize finalize watch read}
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 |
}
# Channel read transform that is just the identity - pass all through
proc idxform {cmd handle args} {
switch -- $cmd {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}
# Channel read transform that is just the identity - pass all through
proc idxform {cmd handle args} {
switch -- $cmd {
initialize {
return {initialize finalize read}
}
finalize {
return
}
read {
lassign $args buffer
return $buffer
}
}
}
# Test that all EOFs pass through full xform stack. Proper data boundaries.
# Check robustness against buffer sizes.
test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -body {
set chan [chan push [chan create read driver] idxform]
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
test iortrans-4.10.1 {[5adbc350683] chan read, handle fleeting EOF} -body {
set chan [chan push [chan create read driver] idxform]
chan configure $chan -buffersize 3
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body {
set chan [chan push [chan create read driver] idxform]
chan configure $chan -buffersize 5
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
rename idxform {}
# Channel read transform that delays the data and always returns something
proc delayxform {cmd handle args} {
variable store
switch -- $cmd {
initialize {
set store($handle) {}
return {initialize finalize read drain}
}
finalize {
unset store($handle)
return
}
read {
lassign $args buffer
if {$store($handle) eq {}} {
set reply [string index $buffer 0]
set store($handle) [string range $buffer 1 end]
} else {
set reply $store($handle)
set store($handle) $buffer
}
return $reply
}
drain {
delayxform read $handle {}
}
}
}
# Test that all EOFs pass through full xform stack. Proper data boundaries.
# Check robustness against buffer sizes.
test iortrans-4.11 {[5adbc350683] chan read, handle fleeting EOF} -body {
set chan [chan push [chan create read driver] delayxform]
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
test iortrans-4.11.1 {[5adbc350683] chan read, handle fleeting EOF} -body {
set chan [chan push [chan create read driver] delayxform]
chan configure $chan -buffersize 3
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body {
set chan [chan push [chan create read driver] delayxform]
chan configure $chan -buffersize 5
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
rename delayxform {}
# Channel read transform that delays the data and may return {}
proc delay2xform {cmd handle args} {
variable store
switch -- $cmd {
initialize {
set store($handle) {}
return {initialize finalize read drain}
}
finalize {
unset store($handle)
return
}
read {
lassign $args buffer
set reply $store($handle)
set store($handle) $buffer
return $reply
}
drain {
delay2xform read $handle {}
}
}
}
test iortrans-4.12 {[5adbc350683] chan read, handle fleeting EOF} -body {
set chan [chan push [chan create read driver] delay2xform]
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
rename delay2xform {}
rename driver {}
|
| ︙ | ︙ | |||
2092 2093 2094 2095 2096 2097 2098 |
# The 'tell' is ok, as it passed through the transform to the base
# channel without invoking the transform handler.
} -cleanup {
thread::send $tidb tempdone
thread::release $tidb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
| < < | 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 |
# The 'tell' is ok, as it passed through the transform to the base
# channel without invoking the transform handler.
} -cleanup {
thread::send $tidb tempdone
thread::release $tidb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup {
#puts <<$tcltest::mainThread>>main
set tida [thread::create -preserved]; #puts <<$tida>>
thread::send $tida {load {} Tcltest}
set tidb [thread::create -preserved]; #puts <<$tidb>>
thread::send $tidb {load {} Tcltest}
} -constraints {testchannel thread notValgrind} -match glob -body {
|
| ︙ | ︙ |
Changes to tests/iogt.test.
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
close $fin
set trail [list]
set got [list]
proc Done {args} {
variable stop 1
}
proc Get {sock} {
| | | | | | | | | | | | | | | 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 |
close $fin
set trail [list]
set got [list]
proc Done {args} {
variable stop 1
}
proc Get {sock} {
variable trail
variable got
if {[eof $sock]} {
Done
lappend trail "xxxxxxxxxxxxx"
close $sock
return
}
lappend trail "vvvvvvvvvvvvv"
lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
lappend trail "============="
#puts stdout $__ ; flush stdout
#read $sock
}
} -constraints {testchannel knownBug} -body {
fevent 1000 500 {20 20 20 10 1} {
variable stop
audit_flow trail -attach $sock
rblocks_t rbuf trail 23 -attach $sock
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
close $f
} -result {xxxghi}
# Driver for a base channel that emits several short "files"
# with each terminated by a fleeting EOF
proc driver {cmd args} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
close $f
} -result {xxxghi}
# Driver for a base channel that emits several short "files"
# with each terminated by a fleeting EOF
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) .....
return {initialize finalize watch read}
}
finalize {
if {![info exists index($chan)]} {return}
unset index($chan) buffer($chan)
return
}
watch {}
read {
set n [lindex $args 1]
if {![info exists index($chan)]} {
driver initialize $chan
}
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
if {[string length $result] == 0} {
driver finalize $chan
}
return $result
}
}
}
test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body {
set chan [chan create read [namespace which driver]]
identity -attach $chan
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
proc delay {op data} {
variable store
switch -- $op {
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
}
}
test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body {
set chan [chan create read [namespace which driver]]
testchannel transform $chan -command [namespace code delay]
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
| | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
}
}
test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body {
set chan [chan create read [namespace which driver]]
testchannel transform $chan -command [namespace code delay]
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
[read $chan] [eof $chan]
} -cleanup {
close $chan
} -result {0 ..... 1 {} 0 ..... 1}
rename delay {}
rename driver {}
|
| ︙ | ︙ |
Changes to tests/linsert.test.
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
} [list a b c]
test linsert-2.6 {syntax (TIP 323)} {
linsert "a\nb\nc" 0
} [list a b c]
test linsert-3.1 {linsert won't modify shared argument objects} {
proc p {} {
| | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
} [list a b c]
test linsert-2.6 {syntax (TIP 323)} {
linsert "a\nb\nc" 0
} [list a b c]
test linsert-3.1 {linsert won't modify shared argument objects} {
proc p {} {
linsert "a b c" 1 "x y"
return "a b c"
}
p
} "a b c"
test linsert-3.2 {linsert won't modify shared argument objects} {
catch {unset lis}
set lis [format "a \"%s\" c" "b"]
linsert $lis 0 [string length $lis]
|
| ︙ | ︙ |
Changes to tests/list.test.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
string equal $srep $lrep
} 1
test list-1.30 {basic null treatment} {
set l [list "\x00abc" "xyz"]
set e "\x00abc xyz"
string equal $l $e
} 1
# For the next round of tests create a list and then pick it apart
# with "index" to make sure that we get back exactly what went in.
set num 0
proc lcheck {testid a b c} {
global num d
| > > > > > > > > > > | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
string equal $srep $lrep
} 1
test list-1.30 {basic null treatment} {
set l [list "\x00abc" "xyz"]
set e "\x00abc xyz"
string equal $l $e
} 1
test list-1.31 {bug [e38dce74e2]} {
set l #foo
set e {}
list {*}$l {*}$e
} {{#foo}}
test list-1.32 {bug [e38dce74e2]} {
set l " #foo"
set e {}
list {*}$l {*}$e
} {{#foo}}
# For the next round of tests create a list and then pick it apart
# with "index" to make sure that we get back exactly what went in.
set num 0
proc lcheck {testid a b c} {
global num d
|
| ︙ | ︙ |
Changes to tests/listObj.test.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 |
test listobj-2.1 {Tcl_SetListObj, use in lappend} {
catch {unset x}
list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x
} {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}}
test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} {
proc return_args {args} {
| | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
test listobj-2.1 {Tcl_SetListObj, use in lappend} {
catch {unset x}
list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x
} {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}}
test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} {
proc return_args {args} {
return $args
}
list [return_args] [return_args x] [return_args x y]
} {{} x {x y}}
test listobj-2.3 {Tcl_SetListObj, zero element count} {
list
} {}
|
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
test listobj-3.4 {Tcl_ListObjAppend, error in conversion} {
set x " \{"
list [catch {lappend x abc def} msg] $msg
} {1 {unmatched open brace in list}}
test listobj-3.5 {Tcl_ListObjAppend, force internal rep array to grow} {
set x ""
list [lappend x 1 1] [lappend x 2 2] [lappend x 3 3] [lappend x 4 4] \
| | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
test listobj-3.4 {Tcl_ListObjAppend, error in conversion} {
set x " \{"
list [catch {lappend x abc def} msg] $msg
} {1 {unmatched open brace in list}}
test listobj-3.5 {Tcl_ListObjAppend, force internal rep array to grow} {
set x ""
list [lappend x 1 1] [lappend x 2 2] [lappend x 3 3] [lappend x 4 4] \
[lappend x 5 5] [lappend x 6 6] [lappend x 7 7] [lappend x 8 8] $x
} {{1 1} {1 1 2 2} {1 1 2 2 3 3} {1 1 2 2 3 3 4 4} {1 1 2 2 3 3 4 4 5 5} {1 1 2 2 3 3 4 4 5 5 6 6} {1 1 2 2 3 3 4 4 5 5 6 6 7 7} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8}}
test listobj-4.1 {Tcl_ListObjAppendElement, list conversion} {
catch {unset x}
list [lappend x 1] $x
} {1 1}
test listobj-4.2 {Tcl_ListObjAppendElement, list conversion} {
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
test listobj-4.4 {Tcl_ListObjAppendElement, error in conversion} {
set x " \{"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open brace in list}}
test listobj-4.5 {Tcl_ListObjAppendElement, force internal rep array to grow} {
set x ""
list [lappend x 1] [lappend x 2] [lappend x 3] [lappend x 4] \
| | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
test listobj-4.4 {Tcl_ListObjAppendElement, error in conversion} {
set x " \{"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open brace in list}}
test listobj-4.5 {Tcl_ListObjAppendElement, force internal rep array to grow} {
set x ""
list [lappend x 1] [lappend x 2] [lappend x 3] [lappend x 4] \
[lappend x 5] [lappend x 6] [lappend x 7] [lappend x 8] $x
} {1 {1 2} {1 2 3} {1 2 3 4} {1 2 3 4 5} {1 2 3 4 5 6} {1 2 3 4 5 6 7} {1 2 3 4 5 6 7 8} {1 2 3 4 5 6 7 8}}
test listobj-5.1 {Tcl_ListObjIndex, basic tests} {
lindex {a b c} 0
} a
test listobj-5.2 {Tcl_ListObjIndex, basic tests} {
lindex a 0
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
list [llength $l] [lindex $l 2]
} {100 c}
# Stolen from dict.test
proc listobjmemcheck script {
set end [lindex [split [memory info] \n] 3 3]
for {set i 0} {$i < 5} {incr i} {
| | | | | | | | | | | | | | | | | | | | | | | 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 |
list [llength $l] [lindex $l 2]
} {100 c}
# Stolen from dict.test
proc listobjmemcheck script {
set end [lindex [split [memory info] \n] 3 3]
for {set i 0} {$i < 5} {incr i} {
uplevel 1 $script
set tmp $end
set end [lindex [split [memory info] \n] 3 3]
}
expr {$end - $tmp}
}
test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints {
testobj memory
} -body {
list [listobjmemcheck {
testobj set 1 [lrepeat 1000 x]
set errorMessage [testlistobj indexmemcheck 1]
testobj freeallvars
}] $errorMessage
} -result {0 {}}
test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints {
testobj memory
} -body {
list [listobjmemcheck {
testobj set 1 [testlistrep new 1000 100 100]
set errorMessage [testlistobj indexmemcheck 1]
testobj freeallvars
}] $errorMessage
} -result {0 {}}
test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints {
testobj memory
} -body {
list [listobjmemcheck {
testobj set 1 [lseq 1000]
set errorMessage [testlistobj indexmemcheck 1]
testobj freeallvars
}] $errorMessage
} -result {0 {}}
test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints {
testobj memory
} -body {
list [listobjmemcheck {
testobj set 1 [lrepeat 1000 x]
set errorMessage [testlistobj getelementsmemcheck 1]
testobj freeallvars
}] $errorMessage
} -result {0 {}}
test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints {
testobj memory
} -body {
list [listobjmemcheck {
testobj set 1 [testlistrep new 1000 100 100]
set errorMessage [testlistobj getelementsmemcheck 1]
testobj freeallvars
}] $errorMessage
} -result {0 {}}
test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints {
testobj memory
} -body {
list [listobjmemcheck {
testobj set 1 [lseq 1000]
set errorMessage [testlistobj getelementsmemcheck 1]
testobj freeallvars
}] $errorMessage
} -result {0 {}}
# Tests for Tcl_ListObjIndex as sematics are different from lindex for
# out of bounds indices. Out of bounds should return a null pointer and
# not empty string.
test listobj-14.1 {Tcl_ListObjIndex out-of-bounds index for native lists} -constraints {
|
| ︙ | ︙ |
Changes to tests/listRep.test.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
testConstraint testlistrep [llength [info commands testlistrep]]
proc describe {l args} {dict get [testlistrep describe $l] {*}$args}
proc irange {first last} {
set l {}
while {$first <= $last} {
| | | | | 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 |
testConstraint testlistrep [llength [info commands testlistrep]]
proc describe {l args} {dict get [testlistrep describe $l] {*}$args}
proc irange {first last} {
set l {}
while {$first <= $last} {
lappend l $first
incr first
}
return $l
}
proc leadSpace {l} {
# Returns the leading space in a list store
return [dict get [describe $l] store firstUsed]
}
proc tailSpace {l} {
# Returns the trailing space in a list store
array set rep [describe $l]
dict with rep(store) {
return [expr {$numAllocated - ($firstUsed + $numUsed)}]
}
}
proc allocated {l} {
# Returns the allocated space in a list store
return [dict get [describe $l] store numAllocated]
}
proc repStoreRefCount {l} {
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
expr {$tailSpace > 0 && $tailSpace >= 2*[leadSpace $l]}
}
proc spaceEqual {l} {
# 1 if lead and tail space shared (diff of 1 at most) and more than 0
set leadSpace [leadSpace $l]
set tailSpace [tailSpace $l]
if {$leadSpace == 0 && $tailSpace == 0} {
| | | | | | | | | | | | | | | | | 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 |
expr {$tailSpace > 0 && $tailSpace >= 2*[leadSpace $l]}
}
proc spaceEqual {l} {
# 1 if lead and tail space shared (diff of 1 at most) and more than 0
set leadSpace [leadSpace $l]
set tailSpace [tailSpace $l]
if {$leadSpace == 0 && $tailSpace == 0} {
# At least one must be positive
return 0
}
set diff [expr {$leadSpace - $tailSpace}]
return [expr {$diff >= -1 && $diff <= 1}]
}
proc storeAddress {l} {
return [describe $l store memoryAddress]
}
proc sameStore {l1 l2} {
expr {[storeAddress $l1] == [storeAddress $l2]}
}
proc hasSpan {l args} {
# Returns 1 if list has a span. If args are specified, they are checked with
# span values (start and length)
array set rep [describe $l]
if {![info exists rep(span)]} {
return 0
}
if {[llength $args] == 0} {
return 1; # No need to check values
}
lassign $args start len
if {[dict get $rep(span) spanStart] == $start &&
[dict get $rep(span) spanLength] == $len} {
return 1
}
return 0
}
proc checkListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} {
# Checks if the internal representation of $l match
# passed arguments. Return "" if yes, else error messages.
array set rep [testlistrep describe $l]
set rep(leadSpace) [dict get $rep(store) firstUsed]
set rep(numAllocated) [dict get $rep(store) numAllocated]
set rep(tailSpace) [expr {
$rep(numAllocated) - ($rep(leadSpace) + [dict get $rep(store) numUsed])
}]
set rep(refCount) [dict get $rep(store) refCount]
if {[info exists rep(span)]} {
set rep(listLen) [dict get $rep(span) spanLength]
} else {
set rep(listLen) [dict get $rep(store) numUsed]
}
set errors [list]
foreach arg {listLen numAllocated leadSpace tailSpace} {
if {$rep($arg) != [set $arg]} {
lappend errors "$arg in list representation ($rep($arg)) is not expected value ([set $arg])."
}
}
# Check refCount only if caller has specified it as non-0
if {$refCount && $refCount != $rep(refCount)} {
lappend errors "refCount in list representation ($rep(refCount)) is not expected value ($refCount)."
}
return $errors
}
proc assertListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} {
# Like check_listrep but raises error
set errors [checkListrep $l $listLen $numAllocated $leadSpace $tailSpace $refCount]
if {[llength $errors]} {
error [join $errors \n]
}
return
}
# The default length should be large enough that doubling the allocation will
# clearly distinguish free space allocation difference between front and back.
# (difference in the two should at least be 2 else we cannot tell if front
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
if {[testConstraint testlistrep]} {
assertListrep [freeSpaceNone] 8 8 0 0 1
assertListrep [freeSpaceLead] 8 11 3 0 1
assertListrep [freeSpaceTail] 8 11 0 3 1
assertListrep [freeSpaceBoth] 8 14 3 3 1
assertListrep [zombieSample] 1000 1200 0 0 1
if {![hasSpan [zombieSample]] || [dict get [testlistrep describe [zombieSample]] span spanStart] == 0} {
| | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
if {[testConstraint testlistrep]} {
assertListrep [freeSpaceNone] 8 8 0 0 1
assertListrep [freeSpaceLead] 8 11 3 0 1
assertListrep [freeSpaceTail] 8 11 0 3 1
assertListrep [freeSpaceBoth] 8 14 3 3 1
assertListrep [zombieSample] 1000 1200 0 0 1
if {![hasSpan [zombieSample]] || [dict get [testlistrep describe [zombieSample]] span spanStart] == 0} {
error "zombieSample span missing or span start is at 0."
}
}
# Define some variables for some indices because the Tcl compiler will do some
# operations completely in byte code if indices are literals
set zero 0
set one 1
|
| ︙ | ︙ |
Changes to tests/lmap.test.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
if {[string compare $i "b"] == 0} continue
set i
}
} {a c d}
test lmap-3.2 {continue tests} {
set x 0
list [lmap i {a b c d} {
| | | | | | | 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 |
if {[string compare $i "b"] == 0} continue
set i
}
} {a c d}
test lmap-3.2 {continue tests} {
set x 0
list [lmap i {a b c d} {
incr x
if {[string compare $i "b"] != 0} continue
set i
}] $x
} {b 4}
test lmap-3.3 {break tests} {
set x 0
list [lmap i {a b c d} {
incr x
if {[string compare $i "c"] == 0} break
set i
}] $x
} {{a b} 3}
# Check for bug similar to #406709
test lmap-3.4 {break tests} {
set a 1
lmap b b {list [concat a; break]; incr a}
incr a
|
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
join [list $a $b $c $d $e] .
}
}}
} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
test lmap-5.9 {lmap only sets vars if repeating loop} {
apply {{} {
| | | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 |
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
join [list $a $b $c $d $e] .
}
}}
} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
test lmap-5.9 {lmap only sets vars if repeating loop} {
apply {{} {
set rgb {65535 0 0}
lmap {r g b} [set rgb] {}
return "r=$r, g=$g, b=$b"
}}
} {r=65535, g=0, b=0}
test lmap-5.10 {lmap only supports local scalar variables} {
apply {{} {
lmap {a(3)} {1 2 3 4} {set {a(3)}}
}}
} {1 2 3 4}
# "lmap" with "continue" and "break" (compiled)
test lmap-6.1 {continue tests} {
apply {{} {
lmap i {a b c d} {
|
| ︙ | ︙ | |||
342 343 344 345 346 347 348 |
# ----- Special cases and bugs -----------------------------------------------
test lmap-7.1 {compiled lmap backward jump works correctly} -setup {
unset -nocomplain x
} -body {
array set x {0 zero 1 one 2 two 3 three}
lsort [apply {{arrayName} {
| | | | | | | | | 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 |
# ----- Special cases and bugs -----------------------------------------------
test lmap-7.1 {compiled lmap backward jump works correctly} -setup {
unset -nocomplain x
} -body {
array set x {0 zero 1 one 2 two 3 three}
lsort [apply {{arrayName} {
upvar 1 $arrayName a
lmap member [array names a] {
list $member [set a($member)]
}
}} x]
} -result [lsort {{0 zero} {1 one} {2 two} {3 three}}]
test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} -setup {
unset -nocomplain x
} -body {
lmap {12.0} {a b c} {
set x 12.0
set x [expr {$x + 1}]
}
} -result {13.0 13.0 13.0}
# Test for incorrect "double evaluation" semantics
test lmap-7.3 {delayed substitution of body} {
apply {{} {
set a 0
lmap a [list 1 2 3] "
set x $a
"
return $x
}}
} {0}
# Related to "foreach" test for [Bug 1189274]; crash on failure
test lmap-7.4 {empty list handling} {
proc crash {} {
|
| ︙ | ︙ |
Changes to tests/load.test.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
load {} Unknown
} -result {no library with prefix "Unknown" is loaded statically}
test load-1.7 {basic errors} -returnCodes error -body {
load -abc foo
} -result {bad option "-abc": must be -global, -lazy, or --}
test load-1.8 {basic errors} -returnCodes error -body {
load -global
| | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
load {} Unknown
} -result {no library with prefix "Unknown" is loaded statically}
test load-1.7 {basic errors} -returnCodes error -body {
load -abc foo
} -result {bad option "-abc": must be -global, -lazy, or --}
test load-1.8 {basic errors} -returnCodes error -body {
load -global
} -result {cannot figure out prefix for -global}
test load-2.1 {basic loading, with guess for package name} \
[list $dll $loaded] {
load -global [file join $testDir tcl9pkga$ext]
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
interp create -safe child
|
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
-body {
list [catch {load [file join $testDir tcl9pkgc$ext] Foo} msg] $msg $errorCode
} -match glob \
-result [list 1 {cannot find symbol "Foo_Init"*} \
{TCL LOOKUP LOAD_SYMBOL *Foo_Init}]
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
list [catch {load [file join $testDir tcl9pkga$ext] {} child} msg] $msg
| | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
-body {
list [catch {load [file join $testDir tcl9pkgc$ext] Foo} msg] $msg $errorCode
} -match glob \
-result [list 1 {cannot find symbol "Foo_Init"*} \
{TCL LOOKUP LOAD_SYMBOL *Foo_Init}]
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
list [catch {load [file join $testDir tcl9pkga$ext] {} child} msg] $msg
} {1 {cannot use library in a safe interpreter: no Pkga_SafeInit procedure}}
test load-3.1 {error in _Init procedure, same interpreter} \
[list $dll $loaded] {
list [catch {load [file join $testDir tcl9pkge$ext] Pkge} msg] \
$msg $::errorInfo $::errorCode
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
load -global [file join $testDir tcl9pkga$ext] Pkga
load {} Pkga x
info loaded x
} -cleanup {
interp delete x
} -result [list [list [file join $testDir tcl9pkga$ext] Pkga]]
| < < < < < | | 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 |
load -global [file join $testDir tcl9pkga$ext] Pkga
load {} Pkga x
info loaded x
} -cleanup {
interp delete x
} -result [list [list [file join $testDir tcl9pkga$ext] Pkga]]
test load-6.1 {errors loading file} [list $dll $loaded] {
catch {load foo foo}
} {1}
test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] {
set x "not loaded"
teststaticlibrary Test 1 0
load {} Test
load {} Test child
list [set x] [child eval set x]
} {loaded loaded}
test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] {
set x "not loaded"
teststaticlibrary Another 0 0
load {} Another
child eval {set x "not loaded"}
list [catch {load {} Another child} msg] $msg \
[child eval set x] [set x]
} {1 {cannot use library in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] {
set x "not loaded"
teststaticlibrary More 0 1
load {} More
set x
} {not loaded}
catch {load [file join $testDir tcl9pkga$ext] Pkga}
|
| ︙ | ︙ |
Changes to tests/lpop.test.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
test lpop-99.1 {performance} -constraints perf -body {
set l [lrepeat 10000 x]
set l2 $l
set t1 [time {
| | | | | | | | | | | | | | 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 |
test lpop-99.1 {performance} -constraints perf -body {
set l [lrepeat 10000 x]
set l2 $l
set t1 [time {
while {[llength $l] >= 2} {
lpop l end
}
}]
set l [lrepeat 30000 x]
set l2 $l
set t2 [time {
while {[llength $l] >= 2} {
lpop l end
}
}]
regexp {\d+} $t1 ms1
regexp {\d+} $t2 ms2
set ratio [expr {double($ms2)/$ms1}]
# Deleting from end should have linear performance
expr {$ratio > 4 ? $ratio : 4}
} -result {4}
test lpop-99.2 {performance} -constraints perf -body {
set l [lrepeat 10000 x]
set l2 $l
set t1 [time {
while {[llength $l] >= 2} {
lpop l 1
}
}]
set l [lrepeat 30000 x]
set l2 $l
set t2 [time {
while {[llength $l] >= 2} {
lpop l 1
}
}]
regexp {\d+} $t1 ms1
regexp {\d+} $t2 ms2
set ratio [expr {double($ms2)/$ms1}]
expr {$ratio > 10 ? $ratio : 10}
} -result {10}
|
| ︙ | ︙ |
Changes to tests/lrange.test.
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
set lss {{} {a} {a b c} {a b c d}}
set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
set lrange lrange
foreach ls $lss {
foreach a $idxs {
foreach b $idxs {
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
set lss {{} {a} {a b c} {a b c d}}
set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
set lrange lrange
foreach ls $lss {
foreach a $idxs {
foreach b $idxs {
# Shared, uncompiled
set ls2 $ls
set expected [list [catch {$lrange $ls $a $b} m] $m]
# Shared, compiled
set tester [list lrange $ls $a $b]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.[incr n].1 {lrange shared compiled} -body \
[list apply [list {} $script]] -result $expected
# Unshared, uncompiled
set tester [string map [list %l [list $ls] %a $a %b $b] {
[string cat l range] [lrange %l 0 end] %a %b
}]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.$n.2 {lrange unshared uncompiled} -body \
[list apply [list {} $script]] -result $expected
# Unshared, compiled
set tester [string map [list %l [list $ls] %a $a %b $b] {
lrange [lrange %l 0 end] %a %b
}]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.$n.3 {lrange unshared compiled} -body \
[list apply [list {} $script]] -result $expected
}
}
}
}}
# cleanup
|
| ︙ | ︙ |
Changes to tests/lreplace.test.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
test lreplace-1.25 {lreplace command} {
concat \"[lreplace {\}\ hello} end end]\"
} {"\}\ "}
test lreplace-1.26 {lreplace command} {
catch {unset foo}
set foo {a b}
list [set foo [lreplace $foo end end]] \
| | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
test lreplace-1.25 {lreplace command} {
concat \"[lreplace {\}\ hello} end end]\"
} {"\}\ "}
test lreplace-1.26 {lreplace command} {
catch {unset foo}
set foo {a b}
list [set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]]
} {a {} {}}
test lreplace-1.27 {lreplace command} -body {
lreplace x 1 1
} -result x
test lreplace-1.28 {lreplace command} -body {
lreplace x 1 1 y
} -result {x y}
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
} -result {0 x}
test lreplace-2.7 {lreplace errors} -body {
list [catch {lreplace x 2 2} msg] $msg
} -result {0 x}
test lreplace-3.1 {lreplace won't modify shared argument objects} {
proc p {} {
| | | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
} -result {0 x}
test lreplace-2.7 {lreplace errors} -body {
list [catch {lreplace x 2 2} msg] $msg
} -result {0 x}
test lreplace-3.1 {lreplace won't modify shared argument objects} {
proc p {} {
lreplace "a b c" 1 1 "x y"
return "a b c"
}
p
} "a b c"
test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} {
lreplace {} 1 1
} {}
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 |
set l {\}\ hello}
concat \"[ledit l end end]\" $l
} {"\}\ " \}\ }
test ledit-1.26 {ledit command} {
catch {unset foo}
set foo {a b}
list [ledit foo end end] $foo \
| | | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
set l {\}\ hello}
concat \"[ledit l end end]\" $l
} {"\}\ " \}\ }
test ledit-1.26 {ledit command} {
catch {unset foo}
set foo {a b}
list [ledit foo end end] $foo \
[ledit foo end end] $foo \
[ledit foo end end] $foo
} {a a {} {} {} {}}
test ledit-1.27 {lsubset command} -body {
set l x
list [ledit l 1 1] $l
} -result {x x}
test ledit-1.28 {ledit command} -body {
set l x
|
| ︙ | ︙ | |||
405 406 407 408 409 410 411 |
unset -nocomplain arr
set arr(y) y
ledit arr(x) 0 0 x
} -returnCodes error -result {can't read "arr(x)": no such element in array}
test ledit-3.1 {ledit won't modify shared argument objects} {
proc p {} {
| | | | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
unset -nocomplain arr
set arr(y) y
ledit arr(x) 0 0 x
} -returnCodes error -result {can't read "arr(x)": no such element in array}
test ledit-3.1 {ledit won't modify shared argument objects} {
proc p {} {
set l "a b c"
ledit l 1 1 "x y"
# The literal in locals table should be unmodified
return [list "a b c" $l]
}
p
} {{a b c} {a {x y} c}}
# Following bugs were in lreplace. Make sure ledit does not have them
test ledit-4.1 {Bug ccc2c2cc98: lreplace edge case} {
set l {}
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
apply {x {
ledit x end 0 A
}} {a b c}
} {a b A c}
test ledit-bug-a366c6efee {Bug [a366c6efee]} -body {
apply {{} {
| | | | | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
apply {x {
ledit x end 0 A
}} {a b c}
} {a b A c}
test ledit-bug-a366c6efee {Bug [a366c6efee]} -body {
apply {{} {
set l { }
string length [ledit l 1 1]; # Force string generation
set result foo
append result " " bar
}}
} -result "foo bar"
# Testing for compiled behaviour. Far too many variations to check with
# spelt-out tests. Note that this *just* checks whether the compiled version
# and the interpreted version are the same, not whether the interpreted
# version is correct.
|
| ︙ | ︙ |
Changes to tests/lsearch.test.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
lsearch -exact {foo bar cat} bart
} -1
test lsearch-2.5 {search modes} {
lsearch -exact {foo bar cat} bar
} 1
test lsearch-2.6 {search modes} -returnCodes error -body {
lsearch -regexp {xyz bbcc *bc*} *bc*
| | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
lsearch -exact {foo bar cat} bart
} -1
test lsearch-2.5 {search modes} {
lsearch -exact {foo bar cat} bar
} 1
test lsearch-2.6 {search modes} -returnCodes error -body {
lsearch -regexp {xyz bbcc *bc*} *bc*
} -result {cannot compile regular expression pattern: invalid quantifier operand}
test lsearch-2.7 {search modes} {
lsearch -regexp {b.x ^bc xy bcx} ^bc
} 3
test lsearch-2.8 {search modes} {
lsearch -glob {xyz bbcc *bc*} *bc*
} 1
test lsearch-2.9 {search modes} {
|
| ︙ | ︙ | |||
656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
} {cb}
test lsearch-27.5 {lsearch -stride + -subindices option} {
lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
} {a a}
test lsearch-27.6 {lsearch -stride + -subindices option} {
lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
} {a a}
test lsearch-28.1 {lsearch -sorted with -stride} -body {
lsearch -sorted -stride 2 {5 3 7 8 9 2} 5
} -result 0
test lsearch-28.2 {lsearch -sorted with -stride} -body {
lsearch -sorted -stride 2 {5 3 7 8 9 2} 3
} -result -1
| > > > > > > | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
} {cb}
test lsearch-27.5 {lsearch -stride + -subindices option} {
lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
} {a a}
test lsearch-27.6 {lsearch -stride + -subindices option} {
lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
} {a a}
test lsearch-27.7 {lsearch -stride + -subindices option single index} {
lsearch -inline -stride 3 -subindices -all -index 1 {{x a} {y b} {x c} {xx a} {xx b} {xx c} {xxx a} {y b} {xxx c}} {y b}
} {{y b} {y b}}
test lsearch-27.8 {lsearch -stride + -subindices option single index} {
lsearch -inline -stride 3 -subindices -all -index end {{x a} {y b} {xc} {xx a} {xx b} {xx c} {xxx a} {y b} {}} *
} {xc {xx c} {}}
test lsearch-28.1 {lsearch -sorted with -stride} -body {
lsearch -sorted -stride 2 {5 3 7 8 9 2} 5
} -result 0
test lsearch-28.2 {lsearch -sorted with -stride} -body {
lsearch -sorted -stride 2 {5 3 7 8 9 2} 3
} -result -1
|
| ︙ | ︙ |
Changes to tests/lseq.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint arithSeriesDouble 1
testConstraint arithSeriesShimmer 1
testConstraint arithSeriesShimmerOk 1
| < | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint arithSeriesDouble 1
testConstraint arithSeriesShimmer 1
testConstraint arithSeriesShimmerOk 1
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]
testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}]
proc memusage {} {
set fd [open /proc/[pid]/statm]
set line [gets $fd]
if {[llength $line] != 7} {
error "Unexpected /proc/pid/statm format"
}
return [lindex $line 5]
}
testConstraint hasMemUsage [expr {![catch {memusage}]}]
# Arg errors
test lseq-1.1 {error cases} -body {
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
test lseq-1.15 {count with decreasing step} {
-body {
lseq 5 count 5 by -2
}
-result {5 3 1 -1 -3}
}
| | > > > > | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
test lseq-1.15 {count with decreasing step} {
-body {
lseq 5 count 5 by -2
}
-result {5 3 1 -1 -3}
}
test lseq-1.16 {large doubles} {
-body {
lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
}
-result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
}
test lseq-1.16.2 {large numbers (bigints are not supported yet)} -body {
lseq 0xfffffffffffffffe 0xffffffffffffffff
} -returnCodes 1 -result {integer value too large to represent}
test lseq-1.17 {too many arguments} -body {
lseq 12 to 24 by 2 with feeling
} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"}
test lseq-1.18 {too many arguments extra valid keyword} -body {
lseq 12 to 24 by 2 count
|
| ︙ | ︙ | |||
135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
test lseq-1.21 {n n by n} {
lseq 66 84 by 3
} {66 69 72 75 78 81 84}
test lseq-1.22 {n n by -n} {
lseq 84 66 by -3
} {84 81 78 75 72 69 66}
#
# Short-hand use cases
#
test lseq-2.2 {step magnitude} {
lseq 10 1 2 ;# this is an empty case since step has wrong sign
} {}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
test lseq-1.21 {n n by n} {
lseq 66 84 by 3
} {66 69 72 75 78 81 84}
test lseq-1.22 {n n by -n} {
lseq 84 66 by -3
} {84 81 78 75 72 69 66}
test lseq-1.23 {consistence, accept double count representable as integer (but use double in series when arguments other than count value are of type double)} {
list [lseq 0.0 2.0] [lseq 3.0] [lseq 0 count 3.0] \
[lseq 0.0 count 3.0] [lseq 0 count 3.0 by 1.0]
} {{0.0 1.0 2.0} {0 1 2} {0 1 2} {0.0 1.0 2.0} {0.0 1.0 2.0}}
test lseq-1.24 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} {
list [lseq 0.0 2] [lseq 0 2.0] [lseq 0.0 count 3] \
[lseq 0 count 3 by 1.0] [lseq 0 .. 2.0] [lseq 0 to 2 by 1.0]
} [lrepeat 6 {0.0 1.0 2.0}]
test lseq-1.25 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} {
list [lseq double(0) 2] [lseq 0 double(2)] [lseq double(0) count 3] \
[lseq 0 count 3 by double(1)] [lseq 0 .. double(2)] [lseq 0 to 2 by double(1)]
} [lrepeat 6 {0.0 1.0 2.0}]
test lseq-1.26 {consistence, double always remains double} {
list [lseq 1 3.0 ] \
[lseq 1 [expr {3.0+0}] ] \
[lseq 1 {3.0+0} ] \
[lseq 1.0 3.0 1] \
[lseq [expr {1.0+0}] [expr {3.0+0}] 1] \
[lseq {1.0+0} {3.0+0} 1]
} [lrepeat 6 {1.0 2.0 3.0}]
test lseq-1.27 {consistence, double always remains double} {
list [lseq 1e50 [expr {1e50+1}] ] \
[lseq 1e50 {1e50+1} ] \
[lseq [expr {1e50+0}] [expr {1e50+1}] 1] \
[lseq {1e50+0} {1e50+1} 1] \
[lseq [expr {1e50+0}] count 1 1] \
[lseq {1e50+0} count 1 1]
} [lrepeat 6 [expr {1e50}]]
#
# Short-hand use cases
#
test lseq-2.2 {step magnitude} {
lseq 10 1 2 ;# this is an empty case since step has wrong sign
} {}
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
[lseq -10 1 -3] \
[lseq 10 -1 -4] \
[lseq -10 -1 3] \
[lseq 10 1 -5]
} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}}
test lseq-3.1 {experiement} -body {
set ans {}
foreach factor [lseq 2.0 10.0] {
set start 1
set end 10
for {set step 1} {$step < 1e8} {} {
set l [lseq $start to $end by $step]
| > > > > > > > > > > > > > > > > > | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
[lseq -10 1 -3] \
[lseq 10 -1 -4] \
[lseq -10 -1 3] \
[lseq 10 1 -5]
} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}}
test lseq-2.19 {expressions as indices} {
list [lseq {1+1}] \
[lseq {1+1} {2+2}] \
[lseq {1+1} count {2+2}] \
[lseq {1+1} {5+5} {2+2}] \
[lseq {1+1} count {2+2} by {2+2}]
} {{0 1} {2 3 4} {2 3 4 5} {2 6 10} {2 6 10 14}}
test lseq-2.20 {expressions as indices, no duplicative eval of expr} {
set i 1
list [lseq {[incr i]}] $i [lseq {0 + [incr i]}] $i [lseq {0.0 + [incr i]}] $i
} {{0 1} 2 {0 1 2} 3 {0 1 2 3} 4}
test lseq-3.0 {expr error: don't swalow expr error (here: divide by zero)} -body {
set i 0; lseq {3/$i}
} -returnCodes [catch {expr {3/0}} res] -result $res
test lseq-3.1 {experiement} -body {
set ans {}
foreach factor [lseq 2.0 10.0] {
set start 1
set end 10
for {set step 1} {$step < 1e8} {} {
set l [lseq $start to $end by $step]
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
set ans
} -cleanup {
unset ans step end start factor l
} -result {OK}
test lseq-3.2 {error case} -body {
lseq foo
| | | | > > > | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
set ans
} -cleanup {
unset ans step end start factor l
} -result {OK}
test lseq-3.2 {error case} -body {
lseq foo
} -returnCodes 1 -match glob -result {invalid bareword "foo"*}
test lseq-3.3 {error case} -body {
lseq 10 foo
} -returnCodes 1 -match glob -result {invalid bareword "foo"*}
test lseq-3.4 {error case} -body {
lseq 25 or 6
} -returnCodes 1 -match glob -result {invalid bareword "or"*}
test lseq-3.5 {simple count and step arguments} -body {
set s [lseq 25 by 6]
list $s length=[llength $s]
} -cleanup {
unset s
} -result {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25}
test lseq-3.6 {error case} -body {
lseq 1 7 or 3
} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by}
test lseq-3.6b {error case} -body {
lseq 1 to 7 or 3
} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by}
test lseq-3.7 {lmap lseq} -body {
lmap x [lseq 5] { expr {$x * $x} }
} -cleanup {unset x} -result {0 1 4 9 16}
test lseq-3.8 {lrange lseq} -body {
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
set srchlist {}
for {set i 5} {$i < 25} {incr i} {
lappend srchlist [lseq $i count 7 by 3]
}
set a [lsearch -all -inline -index 1 $srchlist 23]
set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}]
list [lindex [tcl::unsupported::representation $a] 3] $a $b \
| | | | 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 |
set srchlist {}
for {set i 5} {$i < 25} {incr i} {
lappend srchlist [lseq $i count 7 by 3]
}
set a [lsearch -all -inline -index 1 $srchlist 23]
set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}]
list [lindex [tcl::unsupported::representation $a] 3] $a $b \
[lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3]
} -cleanup {
unset a b srchlist i
} -result {list {{20 23 26 29 32 35 38}} arithseries arithseries}
# lsearch -
# -- should not shimmer lseq list
# -- should not leak lseq elements
test lseq-3.33 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body {
set srchlist {}
for {set i 5} {$i < 25} {incr i} {
lappend srchlist [lseq $i count 7 by 3]
}
set a [lsearch -all -inline -index 1 $srchlist 23]
set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}]
list [lindex [tcl::unsupported::representation $a] 3] $a $b \
[lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3]
} -cleanup {
unset srchlist i a b
} -result {list {{20 23 26 29 32 35 38}} arithseries arithseries}
test lseq-3.34 {"in" operator} -body {
set seq [lseq 0.3 15e4 0.1]
set inlist {}
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
} -cleanup {
unset -nocomplain fred ginger
} -returnCodes 1 -result {bad index "fred": must be integer?[+-]integer? or end?[+-]integer?}
test lseq-4.9 {lrange empty/partial sets} -body {
set res {}
foreach {fred ginger} {7 8 4 9 0 15 9 9 4 2} {
| | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 |
} -cleanup {
unset -nocomplain fred ginger
} -returnCodes 1 -result {bad index "fred": must be integer?[+-]integer? or end?[+-]integer?}
test lseq-4.9 {lrange empty/partial sets} -body {
set res {}
foreach {fred ginger} {7 8 4 9 0 15 9 9 4 2} {
lappend res [lrange [lseq 1 5] $fred $ginger]
}
set res
} -cleanup {unset res fred ginger} -result {{} 5 {1 2 3 4 5} {} {}}
# Panic when using variable value?
test lseq-4.10 {panic using variable index} -body {
set i 0
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 |
} -returnCodes 1 -result {max length of a Tcl list exceeded}
test lseq-4.13 {bug lseq} -constraints has64BitLengths -body {
set l [lseq 0x7fffffffffffffff]
list \
[llength $l] \
[lindex $l end] \
| | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
} -returnCodes 1 -result {max length of a Tcl list exceeded}
test lseq-4.13 {bug lseq} -constraints has64BitLengths -body {
set l [lseq 0x7fffffffffffffff]
list \
[llength $l] \
[lindex $l end] \
[lindex $l 9223372036854775800]
} -cleanup {unset l} -result {9223372036854775807 9223372036854775806 9223372036854775800}
test lseq-4.14 {bug lseq - inconsistent rounding} {
# using a non-integer increment, [lseq] rounding seems to be not consistent:
lseq 4 40 0.1
} {4.0 4.1 4.2 4.3 4.4 4.5 4.6 4.7 4.8 4.9 5.0 5.1 5.2 5.3 5.4 5.5 5.6 5.7 5.8 5.9 6.0 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4 9.5 9.6 9.7 9.8 9.9 10.0 10.1 10.2 10.3 10.4 10.5 10.6 10.7 10.8 10.9 11.0 11.1 11.2 11.3 11.4 11.5 11.6 11.7 11.8 11.9 12.0 12.1 12.2 12.3 12.4 12.5 12.6 12.7 12.8 12.9 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 13.8 13.9 14.0 14.1 14.2 14.3 14.4 14.5 14.6 14.7 14.8 14.9 15.0 15.1 15.2 15.3 15.4 15.5 15.6 15.7 15.8 15.9 16.0 16.1 16.2 16.3 16.4 16.5 16.6 16.7 16.8 16.9 17.0 17.1 17.2 17.3 17.4 17.5 17.6 17.7 17.8 17.9 18.0 18.1 18.2 18.3 18.4 18.5 18.6 18.7 18.8 18.9 19.0 19.1 19.2 19.3 19.4 19.5 19.6 19.7 19.8 19.9 20.0 20.1 20.2 20.3 20.4 20.5 20.6 20.7 20.8 20.9 21.0 21.1 21.2 21.3 21.4 21.5 21.6 21.7 21.8 21.9 22.0 22.1 22.2 22.3 22.4 22.5 22.6 22.7 22.8 22.9 23.0 23.1 23.2 23.3 23.4 23.5 23.6 23.7 23.8 23.9 24.0 24.1 24.2 24.3 24.4 24.5 24.6 24.7 24.8 24.9 25.0 25.1 25.2 25.3 25.4 25.5 25.6 25.7 25.8 25.9 26.0 26.1 26.2 26.3 26.4 26.5 26.6 26.7 26.8 26.9 27.0 27.1 27.2 27.3 27.4 27.5 27.6 27.7 27.8 27.9 28.0 28.1 28.2 28.3 28.4 28.5 28.6 28.7 28.8 28.9 29.0 29.1 29.2 29.3 29.4 29.5 29.6 29.7 29.8 29.9 30.0 30.1 30.2 30.3 30.4 30.5 30.6 30.7 30.8 30.9 31.0 31.1 31.2 31.3 31.4 31.5 31.6 31.7 31.8 31.9 32.0 32.1 32.2 32.3 32.4 32.5 32.6 32.7 32.8 32.9 33.0 33.1 33.2 33.3 33.4 33.5 33.6 33.7 33.8 33.9 34.0 34.1 34.2 34.3 34.4 34.5 34.6 34.7 34.8 34.9 35.0 35.1 35.2 35.3 35.4 35.5 35.6 35.7 35.8 35.9 36.0 36.1 36.2 36.3 36.4 36.5 36.6 36.7 36.8 36.9 37.0 37.1 37.2 37.3 37.4 37.5 37.6 37.7 37.8 37.9 38.0 38.1 38.2 38.3 38.4 38.5 38.6 38.7 38.8 38.9 39.0 39.1 39.2 39.3 39.4 39.5 39.6 39.7 39.8 39.9 40.0}
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
# -- lseq list should not shimmer
# -- lseq elements should not leak
test lseq-4.17 {concat shimmer} -body {
set rng [lseq 8 15 2]
set pre [list A b C]
set pst [list x Y z]
list [concat $pre $rng $pst] \
| | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# -- lseq list should not shimmer
# -- lseq elements should not leak
test lseq-4.17 {concat shimmer} -body {
set rng [lseq 8 15 2]
set pre [list A b C]
set pst [list x Y z]
list [concat $pre $rng $pst] \
[lindex [tcl::unsupported::representation $pre] 3] \
[lindex [tcl::unsupported::representation $rng] 3] \
[lindex [tcl::unsupported::representation $pst] 3]
} -cleanup {unset rng pre pst} -result {{A b C 8 10 12 14 x Y z} list arithseries list}
test lseq-4.18 {concat shimmer} -body {
set rng [lseq 8 15 2]
set pre [list A b C]
set pst [list x Y z]
list [concat $rng $pre $pst] \
[lindex [tcl::unsupported::representation $rng] 3] \
[lindex [tcl::unsupported::representation $pre] 3] \
[lindex [tcl::unsupported::representation $pst] 3]
} -cleanup {unset rng pre pst} -result {{8 10 12 14 A b C x Y z} arithseries list list}
# Test lseq elements as var names
test lseq-4.19 {varnames} -body {
set plist {}
foreach v {auto_execok auto_load auto_qualify} {
lappend plist proc $v [info args $v] [info body $v]
}
set res {}
set varlist [lseq 1 to 4]
foreach $varlist $plist {
lappend res $2 [llength $3]
}
lappend res [lindex [tcl::unsupported::representation $varlist] 3]
} -cleanup {
unset {*}$varlist res varlist v plist
} -result {auto_execok 1 auto_load 2 auto_qualify 2 arithseries}
test lseq-4.20 {lindex on lseq without index args, bug a9625d1f53554f9d} -body {
set res [lindex [lseq 1000]]
list [llength $res] [lindex $res 0] [lindex $res end]
} -cleanup {
unset -nocomplain res
} -result {1000 0 999}
test lseq-4.21.1 {Corner cases: overflows by Inf} -body {
set res {}
lappend res [catch {lseq -1e5555} msg] $msg
lappend res [catch {lseq 1e5555} msg] $msg
lappend res [catch {lseq -Inf} msg] $msg
lappend res [catch {lseq Inf} msg] $msg
lappend res [catch {lseq -1e5555 0} msg] $msg
lappend res [catch {lseq 0 1e5555} msg] $msg
lappend res [catch {lseq -1e5555 1e5555} msg] $msg
lappend res [catch {lseq -Inf -Inf} msg] $msg
lappend res [catch {lseq Inf Inf} msg] $msg
lappend res [catch {lseq 0 .. Inf} msg] $msg
lappend res [catch {lseq -Inf .. 0} msg] $msg
lappend res [catch {lseq 0 .. -Inf} msg] $msg
lappend res [catch {lseq -Inf .. Inf} msg] $msg
lappend res [catch {lseq Inf .. -Inf} msg] $msg
} -cleanup {
unset -nocomplain res
} -result [list {*}{
1 {expected integer but got "-1e5555"}
1 {expected integer but got "1e5555"}
1 {expected integer but got "-Inf"}
1 {expected integer but got "Inf"}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
1 {max length of a Tcl list exceeded}
}]
test lseq-4.21.2 {Corner cases: expected Inf} -body {
set res {}
lappend res [lseq {1e5555+0} count 5]
lappend res [lseq Inf count 5]
lappend res [lseq Inf count 5 by 100]
lappend res [lseq Inf count 5 by Inf]
lappend res [lseq 5 by Inf]
lappend res [lseq 0 count 5 by Inf]
lappend res [lseq 5 by 1e308]
lappend res [lseq 0 count 5 by 1e308]
lappend res [lseq 5 by 5e307]
lappend res [lseq 0 count 5 by 5e307]
} -cleanup {
unset -nocomplain res
} -result [list {*}{
{Inf Inf Inf Inf Inf}
{Inf Inf Inf Inf Inf}
{Inf Inf Inf Inf Inf}
{Inf Inf Inf Inf Inf}
{0.0 Inf Inf Inf Inf}
{0.0 Inf Inf Inf Inf}
{0.0 1e+308 Inf Inf Inf}
{0.0 1e+308 Inf Inf Inf}
{0.0 5e+307 1e+308 1.5e+308 Inf}
{0.0 5e+307 1e+308 1.5e+308 Inf}
}]
test lseq-4.21.3 {Corner cases: expected -Inf} -body {
set res {}
lappend res [lseq {-1e5555+0} count 5]
lappend res [lseq -Inf count 5]
lappend res [lseq -Inf count 5 by 100]
lappend res [lseq -Inf count 5 by -Inf]
lappend res [lseq 5 by -Inf]
lappend res [lseq 0 count 5 by -Inf]
lappend res [lseq 5 by -1e308]
lappend res [lseq 0 count 5 by -1e308]
lappend res [lseq 5 by -5e307]
lappend res [lseq 0 count 5 by -5e307]
} -cleanup {
unset -nocomplain res
} -result [list {*}{
{-Inf -Inf -Inf -Inf -Inf}
{-Inf -Inf -Inf -Inf -Inf}
{-Inf -Inf -Inf -Inf -Inf}
{-Inf -Inf -Inf -Inf -Inf}
{0.0 -Inf -Inf -Inf -Inf}
{0.0 -Inf -Inf -Inf -Inf}
{0.0 -1e+308 -Inf -Inf -Inf}
{0.0 -1e+308 -Inf -Inf -Inf}
{0.0 -5e+307 -1e+308 -1.5e+308 -Inf}
{0.0 -5e+307 -1e+308 -1.5e+308 -Inf}
}]
test lseq-4.21.4 {Corner cases: unexpected Inf - Inf, result to +/-NaN, unexpected NaN} -body {
set res {}
lappend res [list [catch {lseq Inf count 5 by -Inf} msg opt] $msg [dict getd $opt -errorcode ""]]
lappend res [list [catch {lseq -Inf count 5 by Inf} msg opt] $msg [dict getd $opt -errorcode ""]]
lappend res [list [catch {lseq {Inf - Inf} count 5} msg opt] $msg [dict getd $opt -errorcode ""]]
lappend res [list [catch {lseq NaN count 5} msg opt] $msg [dict getd $opt -errorcode ""]]
lappend res [list [catch {lseq NaN count 5 by 100} msg opt] $msg [dict getd $opt -errorcode ""]]
lappend res [list [catch {lseq NaN count 5 by NaN} msg opt] $msg [dict getd $opt -errorcode ""]]
lappend res [list [catch {lseq 5 by NaN} msg opt] $msg [dict getd $opt -errorcode ""]]
lappend res [list [catch {lseq 0 count 5 by NaN} msg opt] $msg [dict getd $opt -errorcode ""]]
join $res \n
} -cleanup {
unset -nocomplain res msg opt
} -result [join [lrepeat 8 {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}}] \n]
test lseq-4.21.5 {Corner cases: unexpected NaN} -body {
set res {}
lappend res [catch {lseq NaN} msg] $msg
lappend res [catch {lseq 0 .. NaN} msg] $msg
} -cleanup {
unset -nocomplain res msg
} -result {1 {expected integer but got "NaN"} 1 {cannot use non-numeric floating-point value "NaN" to estimate length of arith-series}}
test lseq-4.21.6 {Corner cases: empty list, reversed step} -body {
set res {}
lappend res [lseq -5 .. 0 by -1]
lappend res [lseq 5 .. 0 by 1]
lappend res [lseq 0 .. 5 by -1]
lappend res [lseq 0 .. -5 by 1]
} -cleanup {
unset -nocomplain res
} -result {{} {} {} {}}
test lseq-4.21.6-lran {Corner cases: lrange empty list, reversed step} -body {
set res {}
# not shared:
lappend res [lrange [lseq -5 .. 0 by -1] 1 end-1]
lappend res [lrange [lseq 5 .. 0 by 1] 1 end-1]
lappend res [lrange [lseq 0 .. 5 by -1] 1 end-1]
lappend res [lrange [lseq 0 .. -5 by 1] 1 end-1]
# shared:
lappend res [lrange [set l [lseq -5 .. 0 by -1]] 1 end-1]
lappend res [lrange [set l [lseq 5 .. 0 by 1]] 1 end-1]
lappend res [lrange [set l [lseq 0 .. 5 by -1]] 1 end-1]
lappend res [lrange [set l [lseq 0 .. -5 by 1]] 1 end-1]
} -cleanup {
unset -nocomplain res l
} -result {{} {} {} {} {} {} {} {}}
test lseq-4.21.6-lrev {Corner cases: lreverse empty list, reversed step} -body {
set res {}
# not shared:
lappend res [lreverse [lseq -5 .. 0 by -1]]
lappend res [lreverse [lseq 5 .. 0 by 1]]
lappend res [lreverse [lseq 0 .. 5 by -1]]
lappend res [lreverse [lseq 0 .. -5 by 1]]
# shared:
lappend res [lreverse [set l [lseq -5 .. 0 by -1]]]
lappend res [lreverse [set l [lseq 5 .. 0 by 1]]]
lappend res [lreverse [set l [lseq 0 .. 5 by -1]]]
lappend res [lreverse [set l [lseq 0 .. -5 by 1]]]
} -cleanup {
unset -nocomplain res l
} -result {{} {} {} {} {} {} {} {}}
test lseq-4.21.7 {Corner cases: non-empty list, normal step} -body {
set res {}
lappend res [lseq -5 .. 0 ]
lappend res [lseq 5 .. 0 by -1]
lappend res [lseq 0 .. 5 ]
lappend res [lseq 0 .. -5 by -1]
} -cleanup {
unset -nocomplain res
} -result [list {*}{
{-5 -4 -3 -2 -1 0}
{5 4 3 2 1 0}
{0 1 2 3 4 5}
{0 -1 -2 -3 -4 -5}
}]
test lseq-4.21.7-lran {Corner cases: lrange non-empty list, normal step} -body {
set res {}
# not shared:
lappend res [lrange [lseq -5 .. 0 ] 1 end-1]
lappend res [lrange [lseq 5 .. 0 by -1] 1 end-1]
lappend res [lrange [lseq 0 .. 5 ] 1 end-1]
lappend res [lrange [lseq 0 .. -5 by -1] 1 end-1]
# shared:
lappend res [lrange [set l [lseq -5 .. 0 ]] 1 end-1]
lappend res [lrange [set l [lseq 5 .. 0 by -1]] 1 end-1]
lappend res [lrange [set l [lseq 0 .. 5 ]] 1 end-1]
lappend res [lrange [set l [lseq 0 .. -5 by -1]] 1 end-1]
} -cleanup {
unset -nocomplain res l
} -result [lrepeat 2 {*}{
{-4 -3 -2 -1}
{4 3 2 1}
{1 2 3 4}
{-1 -2 -3 -4}
}]
test lseq-4.21.7-lrev {Corner cases: lreverse non-empty list, normal step} -body {
set res {}
# not shared:
lappend res [lreverse [lseq -5 .. 0 ]]
lappend res [lreverse [lseq 5 .. 0 by -1]]
lappend res [lreverse [lseq 0 .. 5 ]]
lappend res [lreverse [lseq 0 .. -5 by -1]]
# shared:
lappend res [lreverse [set l [lseq -5 .. 0 ]]]
lappend res [lreverse [set l [lseq 5 .. 0 by -1]]]
lappend res [lreverse [set l [lseq 0 .. 5 ]]]
lappend res [lreverse [set l [lseq 0 .. -5 by -1]]]
} -cleanup {
unset -nocomplain res l
} -result [lrepeat 2 {*}{
{0 -1 -2 -3 -4 -5}
{0 1 2 3 4 5}
{5 4 3 2 1 0}
{-5 -4 -3 -2 -1 0}
}]
test lseq-convertToList {does not result in a memory error} -body {
trace add variable var1 write [list ::apply [list args {
error {this is an error}
} [namespace current]]]
list [catch {set var1 [lindex [lreplace [lseq 1 2] 1 1 hello] 0]} cres] $cres
} -cleanup {unset var1 cres} -result {1 {can't set "var1": this is an error}}
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
lappend ll [llength [lseq 0 count 200 by .1]]
lappend ll [llength [lseq 0 count 100 by .01]]
lappend ll [llength [lseq 0 count 200 by .01]]
lappend ll [llength [lseq 0 count 100 by .011]]
lappend ll [llength [lseq 0 count 200 by .011]]
} -result {100 200 100 200 100 200}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > | 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 |
lappend ll [llength [lseq 0 count 200 by .1]]
lappend ll [llength [lseq 0 count 100 by .01]]
lappend ll [llength [lseq 0 count 200 by .01]]
lappend ll [llength [lseq 0 count 100 by .011]]
lappend ll [llength [lseq 0 count 200 by .011]]
} -result {100 200 100 200 100 200}
test lseq-bug-f4a4bd7f1070-1 {} -body {
set result {}
lappend result [catch {lseq 3.1} msg]
lappend result $msg
lappend result [catch {lseq 5 count 3.0} msg]
lappend result $msg
lappend result [lseq 3]
lappend result [lseq 3.0]
lappend result [lseq 5.1e1]
lappend result [string compare [lseq 3] [lseq 3.0]]
set result
} -result {1 {expected integer but got "3.1"} 0 {5 6 7} {0 1 2} {0 1 2} {0 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} 0}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/macOSXFCmd.test.
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
[file delete -force -- foo.test]
} {0 {} 0 1 {}}
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} {
catch {file delete -force -- foo.test}
close [open foo.test w]
catch {
set f [open foo.test/..namedfork/rsrc w]
| | | | 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 |
[file delete -force -- foo.test]
} {0 {} 0 1 {}}
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} {
catch {file delete -force -- foo.test}
close [open foo.test w]
catch {
set f [open foo.test/..namedfork/rsrc w]
fconfigure $f -translation lf
puts -nonewline $f "foo"
close $f
}
list [catch {file attributes foo.test -rsrclength} msg] $msg \
[catch {file attributes foo.test -rsrclength 0} msg] $msg \
[catch {file attributes foo.test -rsrclength} msg] $msg \
[file delete -force -- foo.test]
} {0 3 0 {} 0 0 {}}
test macOSXFCmd-3.1 {MacOSXCopyFileAttributes} {macosxFileAttr notRoot} {
catch {file delete -force -- foo.test}
catch {file delete -force -- bar.test}
close [open foo.test w]
catch {
file attributes foo.test -creator FOOC -type FOOT -hidden 1
set f [open foo.test/..namedfork/rsrc w]
fconfigure $f -translation lf
puts -nonewline $f "foo"
close $f
file copy foo.test bar.test
}
list [catch {file attributes bar.test -creator} msg] $msg \
[catch {file attributes bar.test -type} msg] $msg \
[catch {file attributes bar.test -hidden} msg] $msg \
|
| ︙ | ︙ |
Changes to tests/main.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
[llength [package provide tcl::test]]
&& [package vsatisfies [package provide tcl::test] 8.5-]}]
# Procedure to simulate interactive typing of commands, line by line
proc type {chan script} {
foreach line [split $script \n] {
if {[catch {
| | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
[llength [package provide tcl::test]]
&& [package vsatisfies [package provide tcl::test] 8.5-]}]
# Procedure to simulate interactive typing of commands, line by line
proc type {chan script} {
foreach line [split $script \n] {
if {[catch {
puts $chan $line
flush $chan
}]} {
return
}
# Grrr... Behavior depends on this value.
after 1000
}
}
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
close $f
file delete result
removeFile rc
} -result "application-specific initialization failed:\
\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-4.5 {
| | | | | | | | | | | | | | | | 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 |
close $f
file delete result
removeFile rc
} -result "application-specific initialization failed:\
\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-4.5 {
Tcl_Main: Bug 1481986
} -constraints {
exec tcl::test
} -setup {
set rc [makeFile {
testsetmainloop
after 0 {puts "Event callback"}
} rc]
} -body {
set f [open "|[list [interpreter] -appinitprocsetrcfile $rc]" w+]
after 1000
type $f {puts {Interactive output}
exit
}
read $f
} -cleanup {
catch {close $f}
removeFile rc
} -result "Event callback\nInteractive output\n"
# Tests Tcl_Main-5.*: interactive operations
test Tcl_Main-5.1 {
Tcl_Main: tcl_interactive must be boolean
} -constraints {
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
} -constraints {
exec tcl::test
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
catch {chan configure $f -blocking 0}
} -body {
type $f "testsetmainloop
| | | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
} -constraints {
exec tcl::test
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
catch {chan configure $f -blocking 0}
} -body {
type $f "testsetmainloop
after 2000 testexitmainloop
puts \{1 2"
after 4000
type $f "3 4\}"
set code1 [catch {gets $f} line1]
set code2 [catch {gets $f} line2]
set code3 [catch {gets $f} line3]
list $code1 $line1 $code2 $line2 $code3 $line3
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/mathop.test.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 |
# Shared / unshared arguments
# Original / imported
proc TestOp {op args} {
set results {}
# Non byte compiled version, shared args
if {[catch {::tcl::mathop::$op {*}$args} res]} {
| | | | | | | | | | | | | | | | | 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 |
# Shared / unshared arguments
# Original / imported
proc TestOp {op args} {
set results {}
# Non byte compiled version, shared args
if {[catch {::tcl::mathop::$op {*}$args} res]} {
append res " $::errorCode"
}
lappend results $res
# Non byte compiled version, unshared args
set cmd ::tcl::mathop::\$op
foreach arg $args {
append cmd " \[format %s [list $arg]\]"
}
if {[catch $cmd res]} {
append res " $::errorCode"
}
lappend results $res
# Non byte compiled imported
if {[catch {::testmathop2::$op {*}$args} res]} {
append res " $::errorCode"
}
lappend results [string map {testmathop2 tcl::mathop} $res]
# BC version
set argList1 {}
set argList2 {}
set argList3 {}
for {set t 0} {$t < [llength $args]} {incr t} {
lappend argList1 a$t
lappend argList2 \$a$t
lappend argList3 "\[format %s \$a$t\]"
}
# Shared args
proc _TestOp $argList1 "::tcl::mathop::$op [join $argList2]"
# Unshared args
proc _TestOp2 $argList1 "::tcl::mathop::$op [join $argList3]"
# Imported
proc _TestOp3 $argList1 "::testmathop2::$op [join $argList2]"
set ::tcl_traceCompile 0 ;# Set to 2 to help with debug
if {[catch {_TestOp {*}$args} res]} {
append res " $::errorCode"
}
set ::tcl_traceCompile 0
lappend results $res
if {[catch {_TestOp2 {*}$args} res]} {
append res " $::errorCode"
}
lappend results $res
if {[catch {_TestOp3 {*}$args} res]} {
append res " $::errorCode"
}
lappend results [string map {testmathop2 tcl::mathop} $res]
# Check that they do the same
set len [llength $results]
for {set i 0} {$i < ($len - 1)} {incr i} {
set res1 [lindex $results $i]
set res2 [lindex $results $i+1]
if {$res1 ne $res2} {
return "$i:($res1 != $res2)"
}
}
return [lindex $results 0]
}
# start of tests
namespace eval ::testmathop {
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
test mathop-1.6 {compiled +} { + 1 2 3.0 } 6.0
test mathop-1.7 {compiled +} { + 100000000000 2 3 } 100000000005
test mathop-1.8 {compiled +} { + 1 2 300000000000 } 300000000003
test mathop-1.9 {compiled +} { + 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.11 {compiled +: errors} -returnCodes error -body {
+ x 0
| | | | | | | | 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 |
test mathop-1.6 {compiled +} { + 1 2 3.0 } 6.0
test mathop-1.7 {compiled +} { + 100000000000 2 3 } 100000000005
test mathop-1.8 {compiled +} { + 1 2 300000000000 } 300000000003
test mathop-1.9 {compiled +} { + 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.11 {compiled +: errors} -returnCodes error -body {
+ x 0
} -result {cannot use non-numeric string "x" as left operand of "+"}
test mathop-1.12 {compiled +: errors} -returnCodes error -body {
+ nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "+"}
test mathop-1.13 {compiled +: errors} -returnCodes error -body {
+ 0 x
} -result {cannot use non-numeric string "x" as right operand of "+"}
test mathop-1.14 {compiled +: errors} -returnCodes error -body {
+ 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "+"}
test mathop-1.15 {compiled +: errors} -returnCodes error -body {
+ 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "+"}
test mathop-1.16 {compiled +: errors} -returnCodes error -body {
+ 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "+"}
test mathop-1.17 {compiled +: errors} -returnCodes error -body {
+ 0 [error expectedError]
} -result expectedError
test mathop-1.18 {compiled +: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
+ [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
test mathop-1.24 {interpreted +} { $op 1 2 3.0 } 6.0
test mathop-1.25 {interpreted +} { $op 100000000000 2 3 } 100000000005
test mathop-1.26 {interpreted +} { $op 1 2 300000000000 } 300000000003
test mathop-1.27 {interpreted +} { $op 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.29 {interpreted +: errors} -returnCodes error -body {
$op x 0
| | | | | | | | 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 |
test mathop-1.24 {interpreted +} { $op 1 2 3.0 } 6.0
test mathop-1.25 {interpreted +} { $op 100000000000 2 3 } 100000000005
test mathop-1.26 {interpreted +} { $op 1 2 300000000000 } 300000000003
test mathop-1.27 {interpreted +} { $op 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.29 {interpreted +: errors} -returnCodes error -body {
$op x 0
} -result {cannot use non-numeric string "x" as left operand of "+"}
test mathop-1.30 {interpreted +: errors} -returnCodes error -body {
$op nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "+"}
test mathop-1.31 {interpreted +: errors} -returnCodes error -body {
$op 0 x
} -result {cannot use non-numeric string "x" as right operand of "+"}
test mathop-1.32 {interpreted +: errors} -returnCodes error -body {
$op 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "+"}
test mathop-1.33 {interpreted +: errors} -returnCodes error -body {
$op 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "+"}
test mathop-1.34 {interpreted +: errors} -returnCodes error -body {
$op 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "+"}
test mathop-1.35 {interpreted +: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-1.36 {interpreted +: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
test mathop-2.6 {compiled *} { * 1 2 3.0 } 6.0
test mathop-2.7 {compiled *} { * 100000000000 2 3 } 600000000000
test mathop-2.8 {compiled *} { * 1 2 300000000000 } 600000000000
test mathop-2.9 {compiled *} { * 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.11 {compiled *: errors} -returnCodes error -body {
* x 0
| | | | | | | | 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 |
test mathop-2.6 {compiled *} { * 1 2 3.0 } 6.0
test mathop-2.7 {compiled *} { * 100000000000 2 3 } 600000000000
test mathop-2.8 {compiled *} { * 1 2 300000000000 } 600000000000
test mathop-2.9 {compiled *} { * 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.11 {compiled *: errors} -returnCodes error -body {
* x 0
} -result {cannot use non-numeric string "x" as left operand of "*"}
test mathop-2.12 {compiled *: errors} -returnCodes error -body {
* nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "*"}
test mathop-2.13 {compiled *: errors} -returnCodes error -body {
* 0 x
} -result {cannot use non-numeric string "x" as right operand of "*"}
test mathop-2.14 {compiled *: errors} -returnCodes error -body {
* 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "*"}
test mathop-2.15 {compiled *: errors} -returnCodes error -body {
* 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "*"}
test mathop-2.16 {compiled *: errors} -returnCodes error -body {
* 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "*"}
test mathop-2.17 {compiled *: errors} -returnCodes error -body {
* 0 [error expectedError]
} -result expectedError
test mathop-2.18 {compiled *: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
* [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
test mathop-2.24 {interpreted *} { $op 1 2 3.0 } 6.0
test mathop-2.25 {interpreted *} { $op 100000000000 2 3 } 600000000000
test mathop-2.26 {interpreted *} { $op 1 2 300000000000 } 600000000000
test mathop-2.27 {interpreted *} { $op 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.29 {interpreted *: errors} -returnCodes error -body {
$op x 0
| | | | | | | | | | | | | | | | | | 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 |
test mathop-2.24 {interpreted *} { $op 1 2 3.0 } 6.0
test mathop-2.25 {interpreted *} { $op 100000000000 2 3 } 600000000000
test mathop-2.26 {interpreted *} { $op 1 2 300000000000 } 600000000000
test mathop-2.27 {interpreted *} { $op 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.29 {interpreted *: errors} -returnCodes error -body {
$op x 0
} -result {cannot use non-numeric string "x" as left operand of "*"}
test mathop-2.30 {interpreted *: errors} -returnCodes error -body {
$op nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "*"}
test mathop-2.31 {interpreted *: errors} -returnCodes error -body {
$op 0 x
} -result {cannot use non-numeric string "x" as right operand of "*"}
test mathop-2.32 {interpreted *: errors} -returnCodes error -body {
$op 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "*"}
test mathop-2.33 {interpreted *: errors} -returnCodes error -body {
$op 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "*"}
test mathop-2.34 {interpreted *: errors} -returnCodes error -body {
$op 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "*"}
test mathop-2.35 {interpreted *: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-2.36 {interpreted *: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
test mathop-3.1 {compiled !} {! 0} 1
test mathop-3.2 {compiled !} {! 1} 0
test mathop-3.3 {compiled !} {! false} 1
test mathop-3.4 {compiled !} {! true} 0
test mathop-3.5 {compiled !} {! 0.0} 1
test mathop-3.6 {compiled !} {! 10000000000} 0
test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0
test mathop-3.8 {compiled !: errors} -body {
! foobar
} -returnCodes error -result {cannot use non-numeric string "foobar" as operand of "!"}
test mathop-3.9 {compiled !: errors} -body {
! 0 0
} -returnCodes error -result "wrong # args: should be \"! boolean\""
test mathop-3.10 {compiled !: errors} -body {
!
} -returnCodes error -result "wrong # args: should be \"! boolean\""
set op !
test mathop-3.11 {interpreted !} {$op 0} 1
test mathop-3.12 {interpreted !} {$op 1} 0
test mathop-3.13 {interpreted !} {$op false} 1
test mathop-3.14 {interpreted !} {$op true} 0
test mathop-3.15 {interpreted !} {$op 0.0} 1
test mathop-3.16 {interpreted !} {$op 10000000000} 0
test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0
test mathop-3.18 {interpreted !: errors} -body {
$op foobar
} -returnCodes error -result {cannot use non-numeric string "foobar" as operand of "!"}
test mathop-3.19 {interpreted !: errors} -body {
$op 0 0
} -returnCodes error -result "wrong # args: should be \"! boolean\""
test mathop-3.20 {interpreted !: errors} -body {
$op
} -returnCodes error -result "wrong # args: should be \"! boolean\""
test mathop-3.21 {compiled !: error} -returnCodes error -body {
! NaN
} -result {cannot use non-numeric floating-point value "NaN" as operand of "!"}
test mathop-3.22 {interpreted !: error} -returnCodes error -body {
$op NaN
} -result {cannot use non-numeric floating-point value "NaN" as operand of "!"}
test mathop-4.1 {compiled ~} {~ 0} -1
test mathop-4.2 {compiled ~} {~ 1} -2
test mathop-4.3 {compiled ~} {~ 31} -32
test mathop-4.4 {compiled ~} {~ -127} 126
test mathop-4.5 {compiled ~} {~ -0} -1
test mathop-4.6 {compiled ~} {~ 10000000000} -10000000001
test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001
test mathop-4.8 {compiled ~: errors} -body {
~ foobar
} -returnCodes error -result {cannot use non-numeric string "foobar" as operand of "~"}
test mathop-4.9 {compiled ~: errors} -body {
~ 0 0
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.10 {compiled ~: errors} -body {
~
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.11 {compiled ~: errors} -returnCodes error -body {
~ 0.0
} -result {cannot use floating-point value "0.0" as operand of "~"}
test mathop-4.12 {compiled ~: errors} -returnCodes error -body {
~ NaN
} -result {cannot use non-numeric floating-point value "NaN" as operand of "~"}
set op ~
test mathop-4.13 {interpreted ~} {$op 0} -1
test mathop-4.14 {interpreted ~} {$op 1} -2
test mathop-4.15 {interpreted ~} {$op 31} -32
test mathop-4.16 {interpreted ~} {$op -127} 126
test mathop-4.17 {interpreted ~} {$op -0} -1
test mathop-4.18 {interpreted ~} {$op 10000000000} -10000000001
test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001
test mathop-4.20 {interpreted ~: errors} -body {
$op foobar
} -returnCodes error -result {cannot use non-numeric string "foobar" as operand of "~"}
test mathop-4.21 {interpreted ~: errors} -body {
$op 0 0
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.22 {interpreted ~: errors} -body {
$op
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.23 {interpreted ~: errors} -returnCodes error -body {
$op 0.0
} -result {cannot use floating-point value "0.0" as operand of "~"}
test mathop-4.24 {interpreted ~: errors} -returnCodes error -body {
$op NaN
} -result {cannot use non-numeric floating-point value "NaN" as operand of "~"}
test mathop-5.1 {compiled eq} {eq {} a} 0
test mathop-5.2 {compiled eq} {eq a a} 1
test mathop-5.3 {compiled eq} {eq a {}} 0
test mathop-5.4 {compiled eq} {eq a b} 0
test mathop-5.5 {compiled eq} { eq } 1
test mathop-5.6 {compiled eq} {eq a} 1
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
test mathop-6.1 {compiled &} { & } -1
test mathop-6.2 {compiled &} { & 1 } 1
test mathop-6.3 {compiled &} { & 1 2 } 0
test mathop-6.4 {compiled &} { & 3 7 6 } 2
test mathop-6.5 {compiled &} -returnCodes error -body {
& 1.0 2 3
| | | | | | | | | | | | | | | | | | 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 |
test mathop-6.1 {compiled &} { & } -1
test mathop-6.2 {compiled &} { & 1 } 1
test mathop-6.3 {compiled &} { & 1 2 } 0
test mathop-6.4 {compiled &} { & 3 7 6 } 2
test mathop-6.5 {compiled &} -returnCodes error -body {
& 1.0 2 3
} -result {cannot use floating-point value "1.0" as right operand of "&"}
test mathop-6.6 {compiled &} -returnCodes error -body {
& 1 2 3.0
} -result {cannot use floating-point value "3.0" as left operand of "&"}
test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2
test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85
test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2
test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85
test mathop-6.11 {compiled &: errors} -returnCodes error -body {
& x 0
} -result {cannot use non-numeric string "x" as left operand of "&"}
test mathop-6.12 {compiled &: errors} -returnCodes error -body {
& nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "&"}
test mathop-6.13 {compiled &: errors} -returnCodes error -body {
& 0 x
} -result {cannot use non-numeric string "x" as right operand of "&"}
test mathop-6.14 {compiled &: errors} -returnCodes error -body {
& 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "&"}
test mathop-6.15 {compiled &: errors} -returnCodes error -body {
& 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "&"}
test mathop-6.16 {compiled &: errors} -returnCodes error -body {
& 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "&"}
test mathop-6.17 {compiled &: errors} -returnCodes error -body {
& 0 [error expectedError]
} -result expectedError
test mathop-6.18 {compiled &: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
& [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
set op &
test mathop-6.19 {interpreted &} { $op } -1
test mathop-6.20 {interpreted &} { $op 1 } 1
test mathop-6.21 {interpreted &} { $op 1 2 } 0
test mathop-6.22 {interpreted &} { $op 3 7 6 } 2
test mathop-6.23 {interpreted &} -returnCodes error -body {
$op 1.0 2 3
} -result {cannot use floating-point value "1.0" as left operand of "&"}
test mathop-6.24 {interpreted &} -returnCodes error -body {
$op 1 2 3.0
} -result {cannot use floating-point value "3.0" as right operand of "&"}
test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2
test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85
test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2
test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85
test mathop-6.29 {interpreted &: errors} -returnCodes error -body {
$op x 0
} -result {cannot use non-numeric string "x" as left operand of "&"}
test mathop-6.30 {interpreted &: errors} -returnCodes error -body {
$op nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "&"}
test mathop-6.31 {interpreted &: errors} -returnCodes error -body {
$op 0 x
} -result {cannot use non-numeric string "x" as right operand of "&"}
test mathop-6.32 {interpreted &: errors} -returnCodes error -body {
$op 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "&"}
test mathop-6.33 {interpreted &: errors} -returnCodes error -body {
$op 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "&"}
test mathop-6.34 {interpreted &: errors} -returnCodes error -body {
$op 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "&"}
test mathop-6.35 {interpreted &: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-6.36 {interpreted &: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
test mathop-7.1 {compiled |} { | } 0
test mathop-7.2 {compiled |} { | 1 } 1
test mathop-7.3 {compiled |} { | 1 2 } 3
test mathop-7.4 {compiled |} { | 3 7 6 } 7
test mathop-7.5 {compiled |} -returnCodes error -body {
| 1.0 2 3
| | | | | | | | | | | | | | | | | | 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 |
test mathop-7.1 {compiled |} { | } 0
test mathop-7.2 {compiled |} { | 1 } 1
test mathop-7.3 {compiled |} { | 1 2 } 3
test mathop-7.4 {compiled |} { | 3 7 6 } 7
test mathop-7.5 {compiled |} -returnCodes error -body {
| 1.0 2 3
} -result {cannot use floating-point value "1.0" as right operand of "|"}
test mathop-7.6 {compiled |} -returnCodes error -body {
| 1 2 3.0
} -result {cannot use floating-point value "3.0" as left operand of "|"}
test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110
test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503
test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110
test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503
test mathop-7.11 {compiled |: errors} -returnCodes error -body {
| x 0
} -result {cannot use non-numeric string "x" as left operand of "|"}
test mathop-7.12 {compiled |: errors} -returnCodes error -body {
| nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "|"}
test mathop-7.13 {compiled |: errors} -returnCodes error -body {
| 0 x
} -result {cannot use non-numeric string "x" as right operand of "|"}
test mathop-7.14 {compiled |: errors} -returnCodes error -body {
| 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "|"}
test mathop-7.15 {compiled |: errors} -returnCodes error -body {
| 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "|"}
test mathop-7.16 {compiled |: errors} -returnCodes error -body {
| 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "|"}
test mathop-7.17 {compiled |: errors} -returnCodes error -body {
| 0 [error expectedError]
} -result expectedError
test mathop-7.18 {compiled |: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
| [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
set op |
test mathop-7.19 {interpreted |} { $op } 0
test mathop-7.20 {interpreted |} { $op 1 } 1
test mathop-7.21 {interpreted |} { $op 1 2 } 3
test mathop-7.22 {interpreted |} { $op 3 7 6 } 7
test mathop-7.23 {interpreted |} -returnCodes error -body {
$op 1.0 2 3
} -result {cannot use floating-point value "1.0" as left operand of "|"}
test mathop-7.24 {interpreted |} -returnCodes error -body {
$op 1 2 3.0
} -result {cannot use floating-point value "3.0" as right operand of "|"}
test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110
test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503
test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110
test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503
test mathop-7.29 {interpreted |: errors} -returnCodes error -body {
$op x 0
} -result {cannot use non-numeric string "x" as left operand of "|"}
test mathop-7.30 {interpreted |: errors} -returnCodes error -body {
$op nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "|"}
test mathop-7.31 {interpreted |: errors} -returnCodes error -body {
$op 0 x
} -result {cannot use non-numeric string "x" as right operand of "|"}
test mathop-7.32 {interpreted |: errors} -returnCodes error -body {
$op 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "|"}
test mathop-7.33 {interpreted |: errors} -returnCodes error -body {
$op 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "|"}
test mathop-7.34 {interpreted |: errors} -returnCodes error -body {
$op 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "|"}
test mathop-7.35 {interpreted |: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-7.36 {interpreted |: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
test mathop-8.1 {compiled ^} { ^ } 0
test mathop-8.2 {compiled ^} { ^ 1 } 1
test mathop-8.3 {compiled ^} { ^ 1 2 } 3
test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2
test mathop-8.5 {compiled ^} -returnCodes error -body {
^ 1.0 2 3
| | | | | | | | | | | | | | | | | | 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 |
test mathop-8.1 {compiled ^} { ^ } 0
test mathop-8.2 {compiled ^} { ^ 1 } 1
test mathop-8.3 {compiled ^} { ^ 1 2 } 3
test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2
test mathop-8.5 {compiled ^} -returnCodes error -body {
^ 1.0 2 3
} -result {cannot use floating-point value "1.0" as right operand of "^"}
test mathop-8.6 {compiled ^} -returnCodes error -body {
^ 1 2 3.0
} -result {cannot use floating-point value "3.0" as left operand of "^"}
test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110
test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333
test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110
test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333
test mathop-8.11 {compiled ^: errors} -returnCodes error -body {
^ x 0
} -result {cannot use non-numeric string "x" as left operand of "^"}
test mathop-8.12 {compiled ^: errors} -returnCodes error -body {
^ nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "^"}
test mathop-8.13 {compiled ^: errors} -returnCodes error -body {
^ 0 x
} -result {cannot use non-numeric string "x" as right operand of "^"}
test mathop-8.14 {compiled ^: errors} -returnCodes error -body {
^ 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "^"}
test mathop-8.15 {compiled ^: errors} -returnCodes error -body {
^ 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "^"}
test mathop-8.16 {compiled ^: errors} -returnCodes error -body {
^ 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "^"}
test mathop-8.17 {compiled ^: errors} -returnCodes error -body {
^ 0 [error expectedError]
} -result expectedError
test mathop-8.18 {compiled ^: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
^ [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
set op ^
test mathop-8.19 {interpreted ^} { $op } 0
test mathop-8.20 {interpreted ^} { $op 1 } 1
test mathop-8.21 {interpreted ^} { $op 1 2 } 3
test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2
test mathop-8.23 {interpreted ^} -returnCodes error -body {
$op 1.0 2 3
} -result {cannot use floating-point value "1.0" as left operand of "^"}
test mathop-8.24 {interpreted ^} -returnCodes error -body {
$op 1 2 3.0
} -result {cannot use floating-point value "3.0" as right operand of "^"}
test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110
test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333
test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110
test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333
test mathop-8.29 {interpreted ^: errors} -returnCodes error -body {
$op x 0
} -result {cannot use non-numeric string "x" as left operand of "^"}
test mathop-8.30 {interpreted ^: errors} -returnCodes error -body {
$op nan 0
} -result {cannot use non-numeric floating-point value "nan" as left operand of "^"}
test mathop-8.31 {interpreted ^: errors} -returnCodes error -body {
$op 0 x
} -result {cannot use non-numeric string "x" as right operand of "^"}
test mathop-8.32 {interpreted ^: errors} -returnCodes error -body {
$op 0 nan
} -result {cannot use non-numeric floating-point value "nan" as right operand of "^"}
test mathop-8.33 {interpreted ^: errors} -returnCodes error -body {
$op 0o8 0
} -result {cannot use non-numeric string "0o8" as left operand of "^"}
test mathop-8.34 {interpreted ^: errors} -returnCodes error -body {
$op 0 0o8
} -result {cannot use non-numeric string "0o8" as right operand of "^"}
test mathop-8.35 {interpreted ^: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-8.36 {interpreted ^: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
} {70720 70720}
# TODO: % ** << >> - / == != < <= > >= ne in ni
test mathop-13.100 {compiled -: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} {70720 70720}
# TODO: % ** << >> - / == != < <= > >= ne in ni
test mathop-13.100 {compiled -: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
- [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
test mathop-14.100 {compiled /: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
/ [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
}
test mathop-20.1 { zero args, return unit } {
set res {}
foreach op {+ * & ^ | ** < <= > >= == eq} {
lappend res [TestOp $op]
}
set res
} {0 1 -1 0 0 1 1 1 1 1 1 1}
test mathop-20.2 { zero args, not allowed } {
set exp {}
foreach op {~ ! << >> % != ne in ni - /} {
set res [TestOp $op]
if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
}
}
set exp
} {0 0 0 0 0 0 0 0 0 0 0}
test mathop-20.3 { one arg } {
set res {}
foreach val {7 8.3} {
foreach op {+ ** - * / < <= > >= == eq !} {
lappend res [TestOp $op $val]
}
}
set res
} [list 7 7 -7 7 [expr {1.0/7.0}] 1 1 1 1 1 1 0 \
8.3 8.3 -8.3 8.3 [expr {1.0/8.3}] 1 1 1 1 1 1 0]
test mathop-20.4 { one arg, integer only ops } {
set res {}
foreach val {23} {
foreach op {& | ^ ~} {
lappend res [TestOp $op $val]
}
}
set res
} [list 23 23 23 -24]
test mathop-20.5 { one arg, not allowed } {
set exp {}
foreach op {% != ne in ni << >>} {
set res [TestOp $op 1]
if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
}
}
set exp
} {0 0 0 0 0 0 0}
test mathop-20.6 { one arg, error } {
set res {}
set exp {}
foreach vals {x {1 x} {1 1 x} {1 x 1}} {
# skipping - for now, knownbug...
foreach op {+ * / & | ^ **} {
#lappend res [TestOp $op {*}$vals]
#lappend exp "cannot use non-numeric string \"x\" as right operand of \"$op\"\
#ARITH DOMAIN {non-numeric string}"
}
}
foreach op {+ * / & | ^ **} {
lappend res [TestOp $op NaN 1]
lappend exp "cannot use non-numeric floating-point value \"NaN\" as left operand of \"$op\"\
ARITH DOMAIN {non-numeric floating-point value}"
}
expr {$res eq $exp ? 0 : "$res\n$exp"}
} 0
test mathop-20.7 { multi arg } {
set res {}
foreach vals {{1 2} {3 4 5} {4 3 2 1}} {
foreach op {+ - * /} {
lappend res [TestOp $op {*}$vals]
}
}
set res
} [list 3 -1 2 0 12 -6 60 0 10 -2 24 0]
test mathop-20.8 { multi arg, double } {
set res {}
foreach vals {{1.0 2} {3.0 4 5} {4 3.0 2 1}
{1.0 -1.0 1e-18} {1.0 1.0 1e-18}} {
foreach op {+ - * /} {
lappend res [TestOp $op {*}$vals]
}
}
set res
} [list 3.0 -1.0 2.0 0.5 12.0 -6.0 60.0 0.15 10.0 -2.0 24.0 [expr {2.0/3}] 1e-18 2.0 -1e-18 [expr {-1.0/1e-18}] 2.0 -1e-18 1e-18 [expr {1.0/1e-18}]]
test mathop-21.1 { unary ops, bitnot } {
set res {}
lappend res [TestOp ~ 7]
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 |
lappend res [TestOp - -5]
lappend res [TestOp - -2147483648] ;# -2**31
lappend res [TestOp - -9223372036854775808] ;# -2**63
lappend res [TestOp - 354657483923456] ;# wide
lappend res [TestOp - 123456789123456789123456789] ;# big
set res
} [list -7.2 5 2147483648 9223372036854775808 -354657483923456 \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
lappend res [TestOp - -5]
lappend res [TestOp - -2147483648] ;# -2**31
lappend res [TestOp - -9223372036854775808] ;# -2**63
lappend res [TestOp - 354657483923456] ;# wide
lappend res [TestOp - 123456789123456789123456789] ;# big
set res
} [list -7.2 5 2147483648 9223372036854775808 -354657483923456 \
-123456789123456789123456789]
test mathop-21.4 { unary ops, inversion } {
set res {}
lappend res [TestOp / 1]
lappend res [TestOp / 5]
lappend res [TestOp / 5.6]
lappend res [TestOp / -8]
lappend res [TestOp / 354657483923456] ;# wide
lappend res [TestOp / 123456789123456789123456789] ;# big
set res
} [list 1.0 0.2 0.17857142857142858 -0.125 \
2.8196218755553604e-15 8.10000006561e-27]
test mathop-21.5 { unary ops, bad values } {
set res {}
set exp {}
lappend res [TestOp / x]
lappend exp "cannot use non-numeric string \"x\" as right operand of \"/\" ARITH DOMAIN {non-numeric string}"
#lappend res [TestOp - x]
#lappend exp "cannot use non-numeric string \"x\" as operand of \"-\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ~ x]
lappend exp "cannot use non-numeric string \"x\" as operand of \"~\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ! x]
lappend exp "cannot use non-numeric string \"x\" as operand of \"!\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ~ 5.0]
lappend exp "cannot use floating-point value \"5.0\" as operand of \"~\" ARITH DOMAIN {floating-point value}"
expr {$res eq $exp ? 0 : "$res\n$exp"}
} 0
test mathop-21.6 { unary ops, too many } {
set exp {}
foreach op {~ !} {
set res [TestOp $op 7 8]
if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
}
}
set exp
} {0 0}
test mathop-22.1 { bitwise ops } {
set res {}
foreach vals {5 {1 6} {1 2 3} {1 2 3 4}} {
foreach op {& | ^} {
lappend res [TestOp $op {*}$vals]
}
}
set res
} [list 5 5 5 0 7 7 0 3 0 0 7 4]
test mathop-22.2 { bitwise ops on bignums } {
set dig 50
set a 0x[string repeat 5 $dig]
set b 0x[string repeat 7 $dig]
set c 0x[string repeat 9 $dig]
set bn [expr {~$b}]
set cn [expr {~$c}]
set res {}
foreach vals [list [list $a $b] [list $a $c] [list $b $c] \
[list $a $bn] [list $bn $c] [list $bn $cn]] {
foreach op {& | ^} {
lappend res [TestOp $op {*}$vals]
}
}
set exp {}
foreach d {5 7 2 1 D C 1 F E 0 -D -D 8 -9 -1 -0 -E E} {
if {[string match "-*" $d]} {
set d [format %X [expr {15-"0x[string range $d 1 end]"}]]
set val [expr {-"0x[string repeat $d $dig]"-1}]
} else {
set val [expr {"0x[string repeat $d $dig]"}]
}
lappend exp $val
}
expr {$exp eq $res ? 1 : "($res != $exp"}
} 1
test mathop-22.3 { bitwise ops } {
set big1 12135435435354435435342423948763867876
set big2 2746237174783836746262564892918327847
set wide1 12345678912345
set wide2 87321847232215
set small1 87345
set small2 16753
set res {}
foreach op {& | ^} {
lappend res [TestOp $op $big1 $big2]
lappend res [TestOp $op $big1 $wide2]
lappend res [TestOp $op $big1 $small2]
lappend res [TestOp $op $wide1 $big2]
lappend res [TestOp $op $wide1 $wide2]
lappend res [TestOp $op $wide1 $small2]
lappend res [TestOp $op $small1 $big2]
lappend res [TestOp $op $small1 $wide2]
lappend res [TestOp $op $small1 $small2]
}
set res
} [list \
712439449294653815890598856501796 \
78521450111684 \
96 \
2371422390785 \
12275881497169 \
16721 \
33 \
87057 \
16689 \
14880960170688977527789098242825693927 \
12135435435354435435342432749160988407 \
12135435435354435435342423948763884533 \
2746237174783836746262574867174849407 \
87391644647391 \
12345678912377 \
2746237174783836746262564892918415159 \
87321847232503 \
87409 \
14880247731239682873973207643969192131 \
12135435435354435435342354227710876723 \
12135435435354435435342423948763884437 \
2746237174783836746262572495752458622 \
75115763150222 \
12345678895656 \
2746237174783836746262564892918415126 \
87321847145446 \
70720 \
]
test mathop-22.4 { unary ops, bad values } {
set res {}
set exp {}
foreach op {& | ^} {
lappend res [TestOp $op x 5]
lappend exp "cannot use non-numeric string \"x\" as left operand of \"$op\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp $op 5 x]
lappend exp "cannot use non-numeric string \"x\" as right operand of \"$op\" ARITH DOMAIN {non-numeric string}"
}
expr {$res eq $exp ? 0 : "$res\n$exp"}
} 0
test mathop-23.1 { comparison ops, numerical } {
set res {}
set todo {5 {1 6} {1 2 2 3} {4 3 2 1} {5.0 5.0} {6 3 3 1} {5.0 5}}
lappend todo [list 2342476234762482734623842342 234827463876473 3434]
lappend todo [list 2653 453735910264536 453735910264537 2384762472634982746239847637]
lappend todo [list 2653 2384762472634982746239847637]
lappend todo [list 2653 -2384762472634982746239847637]
lappend todo [list 3789253678212653 -2384762472634982746239847637]
lappend todo [list 5.0 6 7.0 8 1e13 1945628567352654 1.1e20 \
6734253647589123456784564378 2.3e50]
set a 7
lappend todo [list $a $a] ;# Same object
foreach vals $todo {
foreach op {< <= > >= == eq} {
lappend res [TestOp $op {*}$vals]
}
}
set res
} [list 1 1 1 1 1 1 \
1 1 0 0 0 0 \
0 1 0 0 0 0 \
0 0 1 1 0 0 \
0 1 0 1 1 1 \
0 0 0 1 0 0 \
0 1 0 1 1 0 \
0 0 1 1 0 0 \
1 1 0 0 0 0 \
1 1 0 0 0 0 \
0 0 1 1 0 0 \
0 0 1 1 0 0 \
1 1 0 0 0 0 \
0 1 0 1 1 1 \
]
test mathop-23.2 { comparison ops, string } {
set res {}
set todo {a {a b} {5 b b c} {d c b a} {xy xy} {gy ef ef ab}}
set a x
lappend todo [list $a $a]
foreach vals $todo {
foreach op {< <= > >= == eq} {
lappend res [TestOp $op {*}$vals]
}
}
set res
} [list 1 1 1 1 1 1 \
1 1 0 0 0 0 \
0 1 0 0 0 0 \
0 0 1 1 0 0 \
0 1 0 1 1 1 \
0 0 0 1 0 0 \
0 1 0 1 1 1 \
]
test mathop-23.3 { comparison ops, nonequal} {
set res {}
foreach vals {{a b} {17.0 0x11} {foo foo} {10 10}} {
foreach op {!= ne} {
lappend res [TestOp $op {*}$vals]
}
}
set res
} [list 1 1 0 1 0 0 0 0 ]
test mathop-24.1 { binary ops } {
set res {}
foreach vals {{3 5} {17 7} {199 5} {293234675763434238476239486 17} \
{5 1} {0 7}} {
foreach op {% << >> in ni} {
lappend res [TestOp $op {*}$vals]
}
}
set res
} [list 3 96 0 0 1 3 2176 0 0 1 4 6368 6 0 1 \
14 38434855421664852505557661908992 2237203031642412097749 0 1 \
0 10 2 0 1 0 0 0 0 1]
test mathop-24.2 { binary ops, modulo } {
# Test different combinations to get all code paths
set res {}
set bigbig 14372423674564535234543545248972634923869
set big 12135435435354435435342423948763867876
set wide 12345678912345
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 |
lappend res [TestOp % $small $big]
lappend res [TestOp % $neg $big]
lappend res [TestOp % $small $wide]
lappend res [TestOp % $neg $wide]
lappend res [TestOp % $wide $small]
set res
} [list 4068119104883679098115293636215358685 \
| | | | | | | | | | | | | | | | | | | | | 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 |
lappend res [TestOp % $small $big]
lappend res [TestOp % $neg $big]
lappend res [TestOp % $small $wide]
lappend res [TestOp % $neg $wide]
lappend res [TestOp % $wide $small]
set res
} [list 4068119104883679098115293636215358685 \
12345678912345 \
12135435435354435435342411603084955531 \
5 \
12135435435354435435342423948763867871 \
5 \
12345678912340 \
0 \
]
test mathop-24.3 { binary ops, bad values } {
set res {}
set exp {}
foreach op {% << >>} {
lappend res [TestOp $op x 1]
lappend exp "cannot use non-numeric string \"x\" as left operand of \"$op\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp $op 1 x]
lappend exp "cannot use non-numeric string \"x\" as right operand of \"$op\" ARITH DOMAIN {non-numeric string}"
}
foreach op {% << >>} {
lappend res [TestOp $op 5.0 1]
lappend exp "cannot use floating-point value \"5.0\" as left operand of \"$op\" ARITH DOMAIN {floating-point value}"
lappend res [TestOp $op 1 5.0]
lappend exp "cannot use floating-point value \"5.0\" as right operand of \"$op\" ARITH DOMAIN {floating-point value}"
}
foreach op {in ni} {
lappend res [TestOp $op 5 "a b \{ c"]
lappend exp "unmatched open brace in list TCL VALUE LIST BRACE"
}
lappend res [TestOp % 5 0]
lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
lappend res [TestOp % 9838923468297346238478737647637375 0]
lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
lappend res [TestOp / 5 0]
lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
lappend res [TestOp / 9838923468297346238478737647637375 0]
lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
expr {$res eq $exp ? 0 : "$res\n$exp"}
} 0
test mathop-24.4 { binary ops, negative shift } {
set res {}
set big -12135435435354435435342423948763867876
set wide -12345678912345
set small -1
|
| ︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 |
set small 5
set neg -5
lappend res [TestOp << $wide $small]
lappend res [TestOp >> $wide $small]
set res
} [list 395061725195040 \
| | | | | | | | | | | | | 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 |
set small 5
set neg -5
lappend res [TestOp << $wide $small]
lappend res [TestOp >> $wide $small]
set res
} [list 395061725195040 \
385802466010 \
]
test mathop-24.7 { binary ops, list search } {
set res {}
foreach op {in ni} {
lappend res [TestOp $op 5 {7 5 8}]
lappend res [TestOp $op hej {foo bar hej}]
lappend res [TestOp $op 5 {7 0x5 8}]
}
set res
} [list 1 1 0 0 0 1]
test mathop-24.8 { binary ops, too many } {
set exp {}
foreach op {<< >> % != ne in ni ~ !} {
set res [TestOp $op 7 8 9]
if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
}
}
set exp
} {0 0 0 0 0 0 0 0 0}
test mathop-25.1 { exp operator } {TestOp ** } 1
test mathop-25.2 { exp operator } {TestOp ** 0 } 0
test mathop-25.3 { exp operator } {TestOp ** 0 5} 0
|
| ︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 |
lappend res [TestOp ** $small $wide]
lappend exp "exponent too large NONE"
lappend res [TestOp ** 2 $big]
lappend exp "exponent too large NONE"
lappend res [TestOp ** $huge 2.1]
lappend exp "Inf"
lappend res [TestOp ** 2 foo]
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
lappend res [TestOp ** $small $wide]
lappend exp "exponent too large NONE"
lappend res [TestOp ** 2 $big]
lappend exp "exponent too large NONE"
lappend res [TestOp ** $huge 2.1]
lappend exp "Inf"
lappend res [TestOp ** 2 foo]
lappend exp "cannot use non-numeric string \"foo\" as right operand of \"**\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ** foo 2]
lappend exp "cannot use non-numeric string \"foo\" as left operand of \"**\" ARITH DOMAIN {non-numeric string}"
expr {$res eq $exp ? 0 : "$res\n$exp"}
} 0
test mathop-26.1 { misc ops, size combinations } {
set big1 12135435435354435435342423948763867876
set big2 2746237174783836746262564892918327847
set wide1 87321847232215
set wide2 12345678912345
set small1 87345
set small2 16753
set res {}
foreach op {+ * - /} {
lappend res [TestOp $op $big1 $big2]
lappend res [TestOp $op $big1 $wide2]
lappend res [TestOp $op $big1 $small2]
lappend res [TestOp $op $wide1 $big2]
lappend res [TestOp $op $wide1 $wide2]
lappend res [TestOp $op $wide1 $small2]
lappend res [TestOp $op $small1 $big2]
lappend res [TestOp $op $small1 $wide2]
lappend res [TestOp $op $small1 $small2]
}
set res
} [list \
14881672610138272181604988841682195723 \
12135435435354435435342436294442780221 \
12135435435354435435342423948763884629 \
2746237174783836746262652214765560062 \
99667526144560 \
87321847248968 \
2746237174783836746262564892918415192 \
12345678999690 \
104098 \
33326783924759424684447891401270222910405366244661685890993770489959542972 \
149820189346379518024969783068410988366610965329220 \
203304949848492856848291628413641078526628 \
239806503039903915972546163440347114360602909991105 \
1078047487961768329845194175 \
1462902906681297895 \
239870086031494220602303730571951345796215 \
1078333324598774025 \
1463290785 \
9389198260570598689079859055845540029 \
12135435435354435435342411603084955531 \
12135435435354435435342423948763851123 \
-2746237174783836746262477571071095632 \
74976168319870 \
87321847215462 \
-2746237174783836746262564892918240502 \
-12345678825000 \
70592 \
4 \
982970278225822587257201 \
724373869477373332259441529801460 \
0 \
7 \
5212311062 \
0 \
0 \
5 \
]
test mathop-26.2 { misc ops, corner cases } {
set res {}
lappend res [TestOp - 0 -2147483648] ;# -2**31
lappend res [TestOp - 0 -9223372036854775808] ;# -2**63
lappend res [TestOp / -9223372036854775808 -1]
lappend res [TestOp * 2147483648 2]
lappend res [TestOp * 9223372036854775808 2]
|
| ︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 |
test mathop-30.8 {ge operator} {::tcl::mathop::ge a c b} 0
test mathop-30.9 {ge operator} {::tcl::mathop::ge 0x0 012} 1
if 0 {
# Compare ops to expr bytecodes
namespace import ::tcl::mathop::*
proc _X {a b c} {
| | | | | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 |
test mathop-30.8 {ge operator} {::tcl::mathop::ge a c b} 0
test mathop-30.9 {ge operator} {::tcl::mathop::ge 0x0 012} 1
if 0 {
# Compare ops to expr bytecodes
namespace import ::tcl::mathop::*
proc _X {a b c} {
set x [+ $a [- $b $c]]
set y [expr {$a + ($b - $c)}]
set z [< $a $b $c]
}
set ::tcl_traceCompile 2
_X 3 4 5
set ::tcl_traceCompile 0
}
# cleanup
|
| ︙ | ︙ |
Changes to tests/msgcat.test.
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
} -body {
namespace eval baz {::msgcat::mc con1}
} -result con1baz
test msgcat-2.5 {mcmset, global scope} -setup {
namespace eval :: {
::msgcat::mcmset foo_BAR {
| | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
} -body {
namespace eval baz {::msgcat::mc con1}
} -result con1baz
test msgcat-2.5 {mcmset, global scope} -setup {
namespace eval :: {
::msgcat::mcmset foo_BAR {
src1 trans1
src2 trans2
}
}
variable locale [mclocale]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
# ov1 should resolve to foo in foo_BAR, foo_BAR_baz
# ov4 should be resolved in none, and call mcunknown
#
variable count 2
variable result
array set result {
foo,ov0 ov0_ROOT foo,ov1 ov1_foo foo,ov2 ov2_foo
| | | | | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
# ov1 should resolve to foo in foo_BAR, foo_BAR_baz
# ov4 should be resolved in none, and call mcunknown
#
variable count 2
variable result
array set result {
foo,ov0 ov0_ROOT foo,ov1 ov1_foo foo,ov2 ov2_foo
foo,ov3 ov3_foo foo,ov4 ov4
foo_BAR,ov0 ov0_ROOT foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR
foo_BAR,ov3 ov3_foo_BAR foo_BAR,ov4 ov4
foo_BAR_baz,ov0 ov0_ROOT foo_BAR_baz,ov1 ov1_foo
foo_BAR_baz,ov2 ov2_foo_BAR
foo_BAR_baz,ov3 ov3_foo_BAR_baz foo_BAR_baz,ov4 ov4
}
variable loc
variable string
foreach loc {foo foo_BAR foo_BAR_baz} {
foreach string {ov0 ov1 ov2 ov3 ov4} {
test msgcat-3.$count {mcset, overlap} -setup {
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
} -body {
mc unk2
} -result unk2
test msgcat-4.4 {mcunknown, overridden} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
| | | | | | 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 |
} -body {
mc unk2
} -result unk2
test msgcat-4.4 {mcunknown, overridden} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return unknown:$dom:$s
}
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mc unk1
} -result {unknown 1}
test msgcat-4.5 {mcunknown, overridden} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return unknown:$dom:$s
}
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mc unk2
} -result {unknown:foo:unk2}
test msgcat-4.6 {mcunknown, uplevel context} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return "unknown:$dom:$s:[expr {[info level] - 1}]"
}
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mc unk2
} -result unknown:foo:unk2:[info level]
# Tests msgcat-5.*: [mcload]
variable locales {{} foo foo_BAR foo_BAR_baz}
set msgdir [makeDirectory msgdir]
foreach loc $locales {
if { $loc eq {} } {
set msg ROOT
} else {
set msg [string tolower $loc]
}
makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg $msgdir
}
variable count 1
foreach loc {foo foo_BAR foo_BAR_baz} {
test msgcat-5.$count {mcload} -setup {
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
mclocale foo
mcpackageconfig set mcfolder $msgdir
} -result 2
foreach loc $locales {
if { $loc eq {} } {
set msg ROOT
| | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
mclocale foo
mcpackageconfig set mcfolder $msgdir
} -result 2
foreach loc $locales {
if { $loc eq {} } {
set msg ROOT
} else {
set msg [string tolower $loc]
}
removeFile $msg.msg $msgdir
}
removeDirectory msgdir
# Tests msgcat-6.*: [mcset], [mc] namespace inheritance
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
interp bgerror {} [namespace code callbackproc]
variable locale
if {![info exist locale]} { set locale [mclocale] }
test msgcat-14.1 {invocation loadcmd} -setup {
mcforgetpackage
| | | | | | | | 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 |
interp bgerror {} [namespace code callbackproc]
variable locale
if {![info exist locale]} { set locale [mclocale] }
test msgcat-14.1 {invocation loadcmd} -setup {
mcforgetpackage
mclocale $locale
mclocale ""
mcloadedlocales clear
set resultvariable ""
} -cleanup {
mcforgetpackage
} -body {
mcpackageconfig set loadcmd [namespace code callbackproc]
mclocale foo_bar
lsort $resultvariable
} -result {foo foo_bar}
test msgcat-14.2 {invocation failed in loadcmd} -setup {
mcforgetpackage
mclocale $locale
mclocale ""
mcloadedlocales clear
} -cleanup {
mcforgetpackage
after cancel set [namespace current]::resultvariable timeout
} -body {
mcpackageconfig set loadcmd [namespace code callbackfailproc]
mclocale foo_bar
# let the bgerror run
after 100 set [namespace current]::resultvariable timeout
vwait [namespace current]::resultvariable
lassign $resultvariable err errdict
list $err [dict get $errdict -code]
} -result {fail 1}
test msgcat-14.3 {invocation changecmd} -setup {
mcforgetpackage
mclocale $locale
mclocale ""
set resultvariable ""
} -cleanup {
mcforgetpackage
} -body {
mcpackageconfig set changecmd [namespace code callbackproc]
mclocale foo_bar
set resultvariable
} -result {foo_bar foo {}}
test msgcat-14.4 {invocation unknowncmd} -setup {
mcforgetpackage
mclocale $locale
mclocale ""
mcloadedlocales clear
set resultvariable ""
} -cleanup {
mcforgetpackage
} -body {
mcpackageconfig set unknowncmd [namespace code callbackproc]
mclocale foo_bar
mc k1 p1
set resultvariable
} -result {foo_bar k1 p1}
test msgcat-14.5 {disable global unknowncmd} -setup {
mcforgetpackage
mclocale $locale
mclocale ""
mcloadedlocales clear
set resultvariable ""
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return unknown:$dom:$s
}
} -cleanup {
mcforgetpackage
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mcpackageconfig set unknowncmd ""
mclocale foo_bar
mc k1%s p1
} -result {k1p1}
test msgcat-14.6 {unknowncmd failing} -setup {
mcforgetpackage
mclocale $locale
mclocale ""
mcloadedlocales clear
set resultvariable ""
} -cleanup {
mcforgetpackage
} -body {
mcpackageconfig set unknowncmd [namespace code callbackfailproc]
|
| ︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 |
namespace eval bar {
::msgcat::mcset foo_BAR con2 con2bar
oo::class create ClassCur
oo::define ClassCur method method1 {} {::msgcat::mc con2}
}
# full namespace is ::msgcat::test:baz
namespace eval baz {
| | | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 |
namespace eval bar {
::msgcat::mcset foo_BAR con2 con2bar
oo::class create ClassCur
oo::define ClassCur method method1 {} {::msgcat::mc con2}
}
# full namespace is ::msgcat::test:baz
namespace eval baz {
set ObjCur [::msgcat::test::bar::ClassCur new]
}
variable locale [mclocale]
mclocale foo_BAR
} -cleanup {
mclocale $locale
namespace eval bar {::msgcat::mcforgetpackage}
namespace delete bar baz
|
| ︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
namespace eval bar {::msgcat::mcforgetpackage}
namespace eval baz {::msgcat::mcforgetpackage}
namespace delete bar baz
} -body {
bar::ObjCur method1
} -result con2baz
# Test msgcat-16.*: command mcpackagenamespaceget
test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
namespace eval baz {msgcat::mcpackagenamespaceget}
} -result ::msgcat::test::baz
test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
| > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
namespace eval bar {::msgcat::mcforgetpackage}
namespace eval baz {::msgcat::mcforgetpackage}
namespace delete bar baz
} -body {
bar::ObjCur method1
} -result con2baz
# HaO 2024-07-15 fix me
# Ticket 91b3a5bb: I have no idea what the following case should do.
# But currently, it raises an error and that should not happen.
# The background is the tklib tooltip package.
# This package captures the caller namespace to later invoke msgcat with current data.
# If the caller namespace is a method, it currently fails.
test msgcat-15.5 {ticket 91b3a5bb: method namespace recorded and evaluated gives error}\
-setup {
oo::class create App {}
oo::define App {
constructor {} { my add_one }
method add_one {} { recordMsgcat }
}
proc ::recordMsgcat {} { set ::nscaller [uplevel 1 {namespace current}] }
set application [App new]
} -cleanup {
$application destroy
App destroy
unset -nocomplain ::nscaller
rename ::recordMsgcat ""
} -body {
namespace eval $::nscaller [list ::msgcat::mc "Test"]
} -returnCodes ok -result Test
# Test msgcat-16.*: command mcpackagenamespaceget
test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
namespace eval baz {msgcat::mcpackagenamespaceget}
} -result ::msgcat::test::baz
test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
namespace eval bar {
oo::class create ClassCur
oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
}
namespace eval baz {
| | | 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 |
test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
namespace eval bar {
oo::class create ClassCur
oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
}
namespace eval baz {
set ObjCur [::msgcat::test::bar::ClassCur new]
}
} -cleanup {
namespace delete bar baz
} -body {
$baz::ObjCur method1
} -result ::msgcat::test::bar
|
| ︙ | ︙ |
Changes to tests/namespace-old.test.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 |
test namespace-old-1.3 {usage for "namespace eval"} {
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-old-1.4 {create new namespaces} {
list [lsort [namespace children :: test_ns_simple*]] \
[namespace eval test_ns_simple {}] \
[namespace eval test_ns_simple2 {}] \
| | | | | | | | | | | 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 |
test namespace-old-1.3 {usage for "namespace eval"} {
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-old-1.4 {create new namespaces} {
list [lsort [namespace children :: test_ns_simple*]] \
[namespace eval test_ns_simple {}] \
[namespace eval test_ns_simple2 {}] \
[lsort [namespace children :: test_ns_simple*]]
} {{} {} {} {::test_ns_simple ::test_ns_simple2}}
test namespace-old-1.5 {access a new namespace} {
namespace eval test_ns_simple { namespace current }
} {::test_ns_simple}
test namespace-old-1.6 {usage for "namespace eval"} {
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-old-1.7 {usage for "namespace eval"} {
list [catch {namespace eval test_ns_xyzzy} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-old-1.8 {command "namespace eval" concatenates args} {
namespace eval test_ns_simple namespace current
} {::test_ns_simple}
test namespace-old-1.9 {add elements to a namespace} {
namespace eval test_ns_simple {
variable test_ns_x 0
proc test {test_ns_x} {
return "test: $test_ns_x"
}
}
} {}
namespace eval test_ns_simple {
variable test_ns_x 0
proc test {test_ns_x} {
return "test: $test_ns_x"
}
}
test namespace-old-1.10 {commands in a namespace} {
namespace eval test_ns_simple { info commands [namespace current]::*}
} {::test_ns_simple::test}
test namespace-old-1.11 {variables in a namespace} {
namespace eval test_ns_simple { info vars [namespace current]::* }
} {::test_ns_simple::test_ns_x}
test namespace-old-1.12 {global vars are separate from locals vars} {
list [test_ns_simple::test 123] [set test_ns_simple::test_ns_x]
} {{test: 123} 0}
test namespace-old-1.13 {add to an existing namespace} {
namespace eval test_ns_simple {
variable test_ns_y 123
proc _backdoor {cmd} {
eval $cmd
}
}
} ""
namespace eval test_ns_simple {
variable test_ns_y 123
proc _backdoor {cmd} {
eval $cmd
}
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
list [catch "::test_ns_simple::_backdoor {return yes!}" msg] $msg
} {0 yes!}
test namespace-old-1.20 {variables in a namespace are hidden} {
list [catch "set test_ns_x" msg] $msg [catch "set test_ns_y" msg] $msg
} {1 {can't read "test_ns_x": no such variable} 1 {can't read "test_ns_y": no such variable}}
test namespace-old-1.21 {using namespace qualifiers} {
list [catch "set test_ns_simple::test_ns_x" msg] $msg \
| | | | | | | | 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 |
list [catch "::test_ns_simple::_backdoor {return yes!}" msg] $msg
} {0 yes!}
test namespace-old-1.20 {variables in a namespace are hidden} {
list [catch "set test_ns_x" msg] $msg [catch "set test_ns_y" msg] $msg
} {1 {can't read "test_ns_x": no such variable} 1 {can't read "test_ns_y": no such variable}}
test namespace-old-1.21 {using namespace qualifiers} {
list [catch "set test_ns_simple::test_ns_x" msg] $msg \
[catch "set test_ns_simple::test_ns_y" msg] $msg
} {0 0 0 123}
test namespace-old-1.22 {using absolute namespace qualifiers} {
list [catch "set ::test_ns_simple::test_ns_x" msg] $msg \
[catch "set ::test_ns_simple::test_ns_y" msg] $msg
} {0 0 0 123}
test namespace-old-1.23 {variables can be accessed within a namespace} {
test_ns_simple::_backdoor {
variable test_ns_x
variable test_ns_y
return "$test_ns_x $test_ns_y"
}
} {0 123}
test namespace-old-1.24 {setting global variables} {
test_ns_simple::_backdoor {variable test_ns_x; set test_ns_x "new val"}
namespace eval test_ns_simple {set test_ns_x}
} {new val}
test namespace-old-1.25 {qualified variables don't need a global declaration} {
namespace eval test_ns_another { variable test_ns_x 456 }
set cmd {set ::test_ns_another::test_ns_x}
list [catch {test_ns_simple::_backdoor "$cmd some-value"} msg] $msg \
[eval $cmd]
} {0 some-value some-value}
test namespace-old-1.26 {namespace qualifiers are okay after $'s} {
namespace eval test_ns_simple { set test_ns_x 12; set test_ns_y 34 }
set cmd {list $::test_ns_simple::test_ns_x $::test_ns_simple::test_ns_y}
list [test_ns_simple::_backdoor $cmd] [eval $cmd]
} {{12 34} {12 34}}
test namespace-old-1.27 {can create commands with null names} {
|
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
# TEST: namespace qualifiers, namespace tail
# -----------------------------------------------------------------------
test namespace-old-3.1 {usage for "namespace qualifiers"} {
list [catch "namespace qualifiers" msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-old-3.2 {querying: namespace qualifiers} {
list [namespace qualifiers ""] \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# TEST: namespace qualifiers, namespace tail
# -----------------------------------------------------------------------
test namespace-old-3.1 {usage for "namespace qualifiers"} {
list [catch "namespace qualifiers" msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-old-3.2 {querying: namespace qualifiers} {
list [namespace qualifiers ""] \
[namespace qualifiers ::] \
[namespace qualifiers x] \
[namespace qualifiers ::x] \
[namespace qualifiers foo::x] \
[namespace qualifiers ::foo::bar::xyz]
} {{} {} {} {} foo ::foo::bar}
test namespace-old-3.3 {usage for "namespace tail"} {
list [catch "namespace tail" msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-old-3.4 {querying: namespace tail} {
list [namespace tail ""] \
[namespace tail ::] \
[namespace tail x] \
[namespace tail ::x] \
[namespace tail foo::x] \
[namespace tail ::foo::bar::xyz]
} {{} {} x x x xyz}
# -----------------------------------------------------------------------
# TEST: delete commands and namespaces
# -----------------------------------------------------------------------
test namespace-old-4.1 {define test namespaces} {
namespace eval test_ns_delete {
namespace eval ns1 {
variable var1 1
proc cmd1 {} {return "cmd1"}
}
namespace eval ns2 {
variable var2 2
proc cmd2 {} {return "cmd2"}
}
namespace eval another {}
lsort [namespace children]
}
} {::test_ns_delete::another ::test_ns_delete::ns1 ::test_ns_delete::ns2}
test namespace-old-4.2 {it's okay to invoke "namespace delete" with no args} {
list [catch {namespace delete} msg] $msg
} {0 {}}
test namespace-old-4.3 {command "namespace delete" doesn't support patterns} {
set cmd {
namespace eval test_ns_delete {namespace delete ns*}
}
list [catch $cmd msg] $msg
} {1 {unknown namespace "ns*" in namespace delete command}}
namespace eval test_ns_delete {
namespace eval ns1 {}
namespace eval ns2 {}
namespace eval another {}
}
test namespace-old-4.4 {command "namespace delete" handles multiple args} {
set cmd {
namespace eval test_ns_delete {
namespace delete \
{*}[namespace children [namespace current] ns?]
}
}
list [catch $cmd msg] $msg [namespace children test_ns_delete]
} {0 {} ::test_ns_delete::another}
# -----------------------------------------------------------------------
# TEST: namespace hierarchy
# -----------------------------------------------------------------------
test namespace-old-5.1 {define nested namespaces} {
set test_ns_var_global "var in ::"
proc test_ns_cmd_global {} {return "cmd in ::"}
namespace eval test_ns_hier1 {
set test_ns_var_hier1 "particular to hier1"
proc test_ns_cmd_hier1 {} {return "particular to hier1"}
set test_ns_level 1
proc test_ns_show {} {return "[namespace current]: 1"}
namespace eval test_ns_hier2 {
set test_ns_var_hier2 "particular to hier2"
proc test_ns_cmd_hier2 {} {return "particular to hier2"}
set test_ns_level 2
proc test_ns_show {} {return "[namespace current]: 2"}
namespace eval test_ns_hier3a {}
namespace eval test_ns_hier3b {}
}
namespace eval test_ns_hier2a {}
namespace eval test_ns_hier2b {}
}
} {}
test namespace-old-5.2 {namespaces can be nested} {
list [namespace eval test_ns_hier1 {namespace current}] \
[namespace eval test_ns_hier1 {
namespace eval test_ns_hier2 {namespace current}
}]
} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
test namespace-old-5.3 {namespace qualifiers work in namespace command} {
list [namespace eval ::test_ns_hier1 {namespace current}] \
[namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \
[namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}]
} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2}
set ::test_ns_var_global "var in ::"
proc test_ns_cmd_global {} {return "cmd in ::"}
namespace eval test_ns_hier1 {
variable test_ns_var_hier1 "particular to hier1"
proc test_ns_cmd_hier1 {} {return "particular to hier1"}
variable test_ns_level 1
proc test_ns_show {} {return "[namespace current]: 1"}
namespace eval test_ns_hier2 {
variable test_ns_var_hier2 "particular to hier2"
proc test_ns_cmd_hier2 {} {return "particular to hier2"}
variable test_ns_level 2
proc test_ns_show {} {return "[namespace current]: 2"}
namespace eval test_ns_hier3a {}
namespace eval test_ns_hier3b {}
}
namespace eval test_ns_hier2a {}
namespace eval test_ns_hier2b {}
}
# TIP 278: secondary lookup disabled for vars, tests disabled with #
test namespace-old-5.4 {nested namespaces can access global namespace} {
list [namespace eval test_ns_hier1 {#set test_ns_var_global}] \
[namespace eval test_ns_hier1 {test_ns_cmd_global}] \
[namespace eval test_ns_hier1::test_ns_hier2 {#set test_ns_var_global}] \
[namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}]
} {{} {cmd in ::} {} {cmd in ::}}
test namespace-old-5.5 {variables in different namespaces don't conflict} {
list [set test_ns_hier1::test_ns_level] \
[set test_ns_hier1::test_ns_hier2::test_ns_level]
} {1 2}
test namespace-old-5.6 {commands in different namespaces don't conflict} {
list [test_ns_hier1::test_ns_show] \
[test_ns_hier1::test_ns_hier2::test_ns_show]
} {{::test_ns_hier1: 1} {::test_ns_hier1::test_ns_hier2: 2}}
test namespace-old-5.7 {nested namespaces don't see variables in parent} {
set cmd {
namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_hier1}
}
list [catch $cmd msg] $msg
} {1 {can't read "test_ns_var_hier1": no such variable}}
test namespace-old-5.8 {nested namespaces don't see commands in parent} {
set cmd {
namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_hier1}
}
list [catch $cmd msg] $msg
} {1 {invalid command name "test_ns_cmd_hier1"}}
test namespace-old-5.9 {usage for "namespace children"} {
list [catch {namespace children test_ns_hier1 y z} msg] $msg
} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}}
test namespace-old-5.10 {command "namespace children" must get valid namespace} -body {
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
list [catch {namespace parent x y} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-old-5.19 {command "namespace parent" must get valid namespace} -body {
namespace parent xyzzy
} -returnCodes error -result {namespace "xyzzy" not found in "::"}
test namespace-old-5.20 {querying namespace parent} {
list [namespace eval :: {namespace parent}] \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
list [catch {namespace parent x y} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-old-5.19 {command "namespace parent" must get valid namespace} -body {
namespace parent xyzzy
} -returnCodes error -result {namespace "xyzzy" not found in "::"}
test namespace-old-5.20 {querying namespace parent} {
list [namespace eval :: {namespace parent}] \
[namespace eval test_ns_hier1 {namespace parent}] \
[namespace eval test_ns_hier1::test_ns_hier2 {namespace parent}] \
[namespace eval test_ns_hier1::test_ns_hier2::test_ns_hier3a {namespace parent}] \
} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
test namespace-old-5.21 {querying namespace parent for explicit namespace} {
list [namespace parent ::] \
[namespace parent test_ns_hier1] \
[namespace parent test_ns_hier1::test_ns_hier2] \
[namespace parent test_ns_hier1::test_ns_hier2::test_ns_hier3a]
} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
# -----------------------------------------------------------------------
# TEST: name resolution and caching
# -----------------------------------------------------------------------
set trigger {namespace eval test_ns_cache2 {namespace current}}
set trigger2 {namespace eval test_ns_cache2::test_ns_cache3 {namespace current}}
test namespace-old-6.1 {relative ns names only looked up in current ns} {
namespace eval test_ns_cache1 {}
namespace eval test_ns_cache2 {}
namespace eval test_ns_cache2::test_ns_cache3 {}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
test namespace-old-6.2 {relative ns names only looked up in current ns} {
namespace eval test_ns_cache1::test_ns_cache2 {}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
test namespace-old-6.3 {relative ns names only looked up in current ns} {
namespace eval test_ns_cache1::test_ns_cache2::test_ns_cache3 {}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
namespace eval test_ns_cache1::test_ns_cache2 {}
test namespace-old-6.4 {relative ns names only looked up in current ns} {
namespace delete test_ns_cache1::test_ns_cache2
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
namespace eval test_ns_cache1 {
proc trigger {} {test_ns_cache_cmd}
}
test namespace-old-6.5 {define test commands} {
proc test_ns_cache_cmd {} {
return "global version"
}
test_ns_cache1::trigger
} {global version}
test namespace-old-6.6 {one-level check for command shadowing} {
proc test_ns_cache1::test_ns_cache_cmd {} {
return "cache1 version"
}
test_ns_cache1::trigger
} {cache1 version}
proc test_ns_cache_cmd {} {
return "global version"
}
test namespace-old-6.7 {renaming commands changes command epoch} -setup {
proc test_ns_cache1::test_ns_cache_cmd {} {
return "cache1 version"
}
} -body {
list [test_ns_cache1::trigger] \
[namespace eval test_ns_cache1 {rename test_ns_cache_cmd test_ns_new}]\
[test_ns_cache1::trigger]
} -result {{cache1 version} {} {global version}}
test namespace-old-6.8 {renaming back handles shadowing} -setup {
proc test_ns_cache1::test_ns_new {} {
return "cache1 version"
}
} -body {
list [test_ns_cache1::trigger] \
[namespace eval test_ns_cache1 {rename test_ns_new test_ns_cache_cmd}]\
[test_ns_cache1::trigger]
} -result {{global version} {} {cache1 version}}
test namespace-old-6.9 {deleting commands changes command epoch} -setup {
proc test_ns_cache1::test_ns_cache_cmd {} {
return "cache1 version"
}
} -body {
list [test_ns_cache1::trigger] \
[namespace eval test_ns_cache1 {rename test_ns_cache_cmd ""}] \
[test_ns_cache1::trigger]
} -result {{cache1 version} {} {global version}}
test namespace-old-6.10 {define test namespaces} {
namespace eval test_ns_cache2 {
proc test_ns_cache_cmd {} {
return "global cache2 version"
}
}
namespace eval test_ns_cache1 {
proc trigger {} {
test_ns_cache2::test_ns_cache_cmd
}
}
namespace eval test_ns_cache1::test_ns_cache2 {
proc trigger {} {
test_ns_cache_cmd
}
}
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
} {{global cache2 version} {global version}}
namespace eval test_ns_cache1 {
proc trigger {} { test_ns_cache2::test_ns_cache_cmd }
namespace eval test_ns_cache2 {
proc trigger {} { test_ns_cache_cmd }
}
}
test namespace-old-6.11 {commands affect all parent namespaces} {
proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} {
return "cache2 version"
}
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
} {{cache2 version} {cache2 version}}
# TIP 278: secondary lookup disabled, catch added, result changed from {global version}
test namespace-old-6.12 {define test variables} {
variable test_ns_cache_var "global version"
set trigger {set test_ns_cache_var}
list [catch {namespace eval test_ns_cache1 $trigger} msg] $msg
} {1 {can't read "test_ns_cache_var": no such variable}}
set trigger {set test_ns_cache_var}
test namespace-old-6.13 {one-level check for variable shadowing} {
namespace eval test_ns_cache1 {
variable test_ns_cache_var "cache1 version"
}
namespace eval test_ns_cache1 $trigger
} {cache1 version}
variable ::test_ns_cache_var "global version"
# TIP 278: secondary lookup disabled, catch added, result changed from {global version}
test namespace-old-6.14 {deleting variables changes variable epoch} {
namespace eval test_ns_cache1 {
variable test_ns_cache_var "cache1 version"
}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 {unset test_ns_cache_var}] \
[catch {namespace eval test_ns_cache1 $trigger}]
} {{cache1 version} {} 1}
# TIP 278: secondary lookup disabled, catch added, result changed
test namespace-old-6.15 {define test namespaces} {
namespace eval test_ns_cache2 {
variable test_ns_cache_var "global cache2 version"
}
set trigger2 {set test_ns_cache2::test_ns_cache_var}
catch {list [namespace eval test_ns_cache1 $trigger2] \
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]}
} 1
set trigger2 {set test_ns_cache2::test_ns_cache_var}
test namespace-old-6.16 {public variables affect all parent namespaces} {
variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version"
list [namespace eval test_ns_cache1 $trigger2] \
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]
} {{cache2 version} {cache2 version}}
test namespace-old-6.17 {usage for "namespace which"} {
list [catch "namespace which -baz x" msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-old-6.18 {usage for "namespace which"} {
# Presume no imported command called -command ;^)
namespace which -command
} {}
test namespace-old-6.19 {querying: namespace which -command} {
proc test_ns_cache1::test_ns_cache_cmd {} {
return "cache1 version"
}
list [namespace eval :: {namespace which test_ns_cache_cmd}] \
[namespace eval test_ns_cache1 {namespace which test_ns_cache_cmd}] \
[namespace eval :: {namespace which -command test_ns_cache_cmd}] \
[namespace eval test_ns_cache1 {namespace which -command test_ns_cache_cmd}]
} {::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd ::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd}
test namespace-old-6.20 {command "namespace which" may not find commands} {
namespace eval test_ns_cache1 {namespace which -command xyzzy}
} {}
variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version"
test namespace-old-6.21 {querying: namespace which -variable} {
namespace eval test_ns_cache1::test_ns_cache2 {
namespace which -variable test_ns_cache_var
}
} {::test_ns_cache1::test_ns_cache2::test_ns_cache_var}
test namespace-old-6.22 {command "namespace which" may not find variables} {
namespace eval test_ns_cache1 {namespace which -variable xyzzy}
} {}
# -----------------------------------------------------------------------
# TEST: uplevel/upvar across namespace boundaries
# -----------------------------------------------------------------------
test namespace-old-7.1 {define test namespace} {
namespace eval test_ns_uplevel {
variable x 0
variable y 1
proc show_vars {num} {
return [uplevel $num {info vars}]
}
proc test_uplevel {num} {
set a 0
set b 1
namespace eval ::test_ns_uplevel " return \[show_vars $num\] "
}
}
} {}
namespace eval test_ns_uplevel {
variable x 0
variable y 1
proc show_vars {num} {
return [uplevel $num {info vars}]
}
proc test_uplevel {num} {
set a 0
set b 1
namespace eval ::test_ns_uplevel " return \[show_vars $num\] "
}
}
test namespace-old-7.2 {uplevel can access namespace call frame} {
list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \
[expr {"y" in [test_ns_uplevel::test_uplevel 1]}]
} {1 1}
test namespace-old-7.3 {uplevel can go beyond namespace call frame} {
lsort [test_ns_uplevel::test_uplevel 2]
} {a b num}
test namespace-old-7.4 {uplevel can go up to global context} {
expr {[test_ns_uplevel::test_uplevel 3] == [info globals]}
} {1}
test namespace-old-7.5 {absolute call frame references work too} {
list [expr {"x" in [test_ns_uplevel::test_uplevel #2]}] \
[expr {"y" in [test_ns_uplevel::test_uplevel #2]}]
} {1 1}
test namespace-old-7.6 {absolute call frame references work too} {
lsort [test_ns_uplevel::test_uplevel #1]
} {a b num}
test namespace-old-7.7 {absolute call frame references work too} {
expr {[test_ns_uplevel::test_uplevel #0] == [info globals]}
} {1}
test namespace-old-7.8 {namespaces are included in the call stack} {
namespace eval test_ns_upvar {
variable scope "test_ns_upvar"
proc show_val {var num} {
upvar $num $var x
return $x
}
proc test_upvar {num} {
set scope "test_ns_upvar::test_upvar"
namespace eval ::test_ns_upvar " return \[show_val scope $num\] "
}
}
} {}
namespace eval test_ns_upvar {
variable scope "test_ns_upvar"
proc show_val {var num} {
upvar $num $var x
return $x
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
} {test_ns_upvar::test_upvar}
# -----------------------------------------------------------------------
# TEST: variable traces across namespace boundaries
# -----------------------------------------------------------------------
test namespace-old-8.1 {traces work across namespace boundaries} {
namespace eval test_ns_trace {
| | | | | | | | | | | | | | | | | | | | | 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 |
} {test_ns_upvar::test_upvar}
# -----------------------------------------------------------------------
# TEST: variable traces across namespace boundaries
# -----------------------------------------------------------------------
test namespace-old-8.1 {traces work across namespace boundaries} {
namespace eval test_ns_trace {
namespace eval foo {
variable x ""
}
variable status ""
proc monitor {name1 name2 op} {
variable status
lappend status "$op: $name1"
}
trace add variable foo::x {read write unset} [namespace code monitor]
}
set test_ns_trace::foo::x "yes!"
set test_ns_trace::foo::x
unset test_ns_trace::foo::x
namespace eval test_ns_trace { set status }
} {{write: test_ns_trace::foo::x} {read: test_ns_trace::foo::x} {unset: test_ns_trace::foo::x}}
# -----------------------------------------------------------------------
# TEST: imported commands
# -----------------------------------------------------------------------
test namespace-old-9.1 {empty "namespace export" list} {
list [catch "namespace export" msg] $msg
} {0 {}}
test namespace-old-9.2 {usage for "namespace export" command} {
list [catch "namespace export test_ns_trace::zzz" msg] $msg
} {1 {invalid export pattern "test_ns_trace::zzz": pattern can't specify a namespace}}
test namespace-old-9.3 {define test namespaces for import} {
namespace eval test_ns_export {
namespace export cmd1 cmd2 cmd3
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
proc cmd5 {args} {return "cmd5: $args"}
proc cmd6 {args} {return "cmd6: $args"}
}
lsort [info commands test_ns_export::*]
} {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6}
namespace eval test_ns_export {
namespace export cmd1 cmd2 cmd3
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
proc cmd5 {args} {return "cmd5: $args"}
proc cmd6 {args} {return "cmd6: $args"}
}
test namespace-old-9.4 {check export status} {
set x ""
namespace eval test_ns_import {
namespace export cmd1 cmd2
namespace import ::test_ns_export::*
}
foreach cmd [lsort [info commands test_ns_import::*]] {
lappend x $cmd
}
set x
} {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3}
namespace eval test_ns_import {
namespace export cmd1 cmd2
namespace import ::test_ns_export::*
}
|
| ︙ | ︙ | |||
713 714 715 716 717 718 719 |
} {cmd1 cmd2}
namespace import test_ns_import::cmd*
test namespace-old-9.9 {imported commands work just the same as original} {
list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6]
} {{cmd1: test 1 2 3} {cmd1: test 4 5 6}}
test namespace-old-9.10 {commands can be imported from many namespaces} {
namespace eval test_ns_import2 {
| | | | | | | 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
} {cmd1 cmd2}
namespace import test_ns_import::cmd*
test namespace-old-9.9 {imported commands work just the same as original} {
list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6]
} {{cmd1: test 1 2 3} {cmd1: test 4 5 6}}
test namespace-old-9.10 {commands can be imported from many namespaces} {
namespace eval test_ns_import2 {
namespace export ncmd ncmd1 ncmd2
proc ncmd {args} {return "ncmd: $args"}
proc ncmd1 {args} {return "ncmd1: $args"}
proc ncmd2 {args} {return "ncmd2: $args"}
proc ncmd3 {args} {return "ncmd3: $args"}
}
namespace import test_ns_import2::*
lsort [concat [info commands cmd*] [info commands ncmd*]]
} {cmd1 cmd2 ncmd ncmd1 ncmd2}
namespace eval test_ns_import2 {
namespace export ncmd ncmd1 ncmd2
proc ncmd {args} {return "ncmd: $args"}
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
} {cmd2 ncmd ncmd1 ncmd2}
catch { rename cmd1 "" }
test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} {
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-old-9.13 {command "namespace forget" ignores patterns that don't match} {
list [catch {namespace forget test_ns_import::xy*zzy} msg] $msg \
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
} {cmd2 ncmd ncmd1 ncmd2}
catch { rename cmd1 "" }
test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} {
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-old-9.13 {command "namespace forget" ignores patterns that don't match} {
list [catch {namespace forget test_ns_import::xy*zzy} msg] $msg \
[lsort [info commands cmd?]]
} {0 {} cmd2}
test namespace-old-9.14 {imported commands can be removed} {
namespace forget test_ns_import::cmd?
list [lsort [info commands cmd?]] \
[catch {cmd1 another test} msg] $msg
} {{} 1 {invalid command name "cmd1"}}
test namespace-old-9.15 {existing commands can't be overwritten} {
proc cmd1 {x y} {
return [expr {$x+$y}]
}
list [catch {namespace import test_ns_import::cmd?} msg] $msg \
[cmd1 3 5]
} {1 {can't import command "cmd1": already exists} 8}
test namespace-old-9.16 {use "-force" option to override existing commands} {
proc cmd1 {x y} { return [expr {$x+$y}] }
list [cmd1 3 5] \
[namespace import -force test_ns_import::cmd?] \
[cmd1 3 5]
} {8 {} {cmd1: 3 5}}
test namespace-old-9.17 {commands can be imported into many namespaces} {
namespace eval test_ns_import_use {
namespace import ::test_ns_import::* ::test_ns_import2::ncmd?
lsort [concat [info commands ::test_ns_import_use::cmd*] \
[info commands ::test_ns_import_use::ncmd*]]
}
} {::test_ns_import_use::cmd1 ::test_ns_import_use::cmd2 ::test_ns_import_use::ncmd1 ::test_ns_import_use::ncmd2}
test namespace-old-9.18 {when command is deleted, imported commands go away} {
namespace eval test_ns_import { rename cmd1 "" }
list [info commands cmd1] \
[namespace eval test_ns_import_use {info commands cmd1}]
} {{} {}}
test namespace-old-9.19 {when namesp is deleted, all imported commands go away} {
namespace delete test_ns_import test_ns_import2
list [info commands cmd*] \
[info commands ncmd*] \
[namespace eval test_ns_import_use {info commands cmd*}] \
[namespace eval test_ns_import_use {info commands ncmd*}] \
} {{} {} {} {}}
# -----------------------------------------------------------------------
# TEST: scoped values
# -----------------------------------------------------------------------
test namespace-old-10.1 {define namespace for scope test} {
namespace eval test_ns_inscope {
variable x "x-value"
proc show {args} {
return "show: $args"
}
proc do {args} {
return [eval $args]
}
list [set x] [show test]
}
} {x-value {show: test}}
test namespace-old-10.2 {command "namespace code" requires one argument} {
list [catch {namespace code} msg] $msg
} {1 {wrong # args: should be "namespace code arg"}}
test namespace-old-10.3 {command "namespace code" requires one argument} {
list [catch {namespace code first "second arg" third} msg] $msg
} {1 {wrong # args: should be "namespace code arg"}}
test namespace-old-10.4 {command "namespace code" gets current namesp context} {
namespace eval test_ns_inscope {
namespace code {"1 2 3" "4 5" 6}
}
} {::namespace inscope ::test_ns_inscope {"1 2 3" "4 5" 6}}
test namespace-old-10.5 {with one arg, first "scope" sticks} {
set sval [namespace eval test_ns_inscope {namespace code {one two}}]
namespace code $sval
} {::namespace inscope ::test_ns_inscope {one two}}
test namespace-old-10.6 {with many args, each "scope" adds new args} {
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
list [eval $cref "a" "b c" "d e f"]
} {{show: a b c d e f}}
namespace eval test_ns_inscope {
variable x "x-value"
}
test namespace-old-10.8 {scoped commands execute in namespace context} {
set cref [namespace eval test_ns_inscope {
| | | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 |
list [eval $cref "a" "b c" "d e f"]
} {{show: a b c d e f}}
namespace eval test_ns_inscope {
variable x "x-value"
}
test namespace-old-10.8 {scoped commands execute in namespace context} {
set cref [namespace eval test_ns_inscope {
namespace code {set x "some new value"}
}]
list [set test_ns_inscope::x] [eval $cref] [set test_ns_inscope::x]
} {x-value {some new value} {some new value}}
foreach cmd [info commands test_ns_*] {
rename $cmd ""
}
|
| ︙ | ︙ |
Changes to tests/namespace.test.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
namespace children :: test_ns_*
} {}
catch {unset l}
test namespace-2.1 {Tcl_GetCurrentNamespace} {
list [namespace current] [namespace eval {} {namespace current}] \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
namespace children :: test_ns_*
} {}
catch {unset l}
test namespace-2.1 {Tcl_GetCurrentNamespace} {
list [namespace current] [namespace eval {} {namespace current}] \
[namespace eval {} {namespace current}]
} {:: :: ::}
test namespace-2.2 {Tcl_GetCurrentNamespace} {
set l {}
lappend l [namespace current]
namespace eval test_ns_1 {
lappend ::l [namespace current]
namespace eval foo {
lappend ::l [namespace current]
}
}
lappend l [namespace current]
} {:: ::test_ns_1 ::test_ns_1::foo ::}
test namespace-3.1 {Tcl_GetGlobalNamespace} {
namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } }
# namespace children uses Tcl_GetGlobalNamespace
namespace eval test_ns_1 {namespace children foo b*}
} {::test_ns_1::foo::bar}
test namespace-4.1 {Tcl_PushCallFrame with isProcCallFrame=1} {
namespace eval test_ns_1 {
variable v 123
proc p {} {
variable v
return $v
}
}
test_ns_1::p ;# does Tcl_PushCallFrame to push p's namespace
} {123}
test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} {
namespace eval test_ns_1::baz {} ;# does Tcl_PushCallFrame to create baz
proc test_ns_1::baz::p {} {
variable v
set v 789
set v}
test_ns_1::baz::p
} {789}
test namespace-5.1 {Tcl_PopCallFrame, no vars} {
namespace eval test_ns_1::blodge {} ;# pushes then pops frame
} {}
test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} -setup {
namespace eval test_ns_1 {}
} -body {
proc test_ns_1::r {} {
set a 123
}
test_ns_1::r ;# pushes then pop's r's frame
} -result {123}
test namespace-6.1 {Tcl_CreateNamespace} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [lsort [namespace children :: test_ns_*]] \
[namespace eval test_ns_1 {namespace current}] \
[namespace eval test_ns_2 {namespace current}] \
[namespace eval ::test_ns_3 {namespace current}] \
[namespace eval ::test_ns_4 \
{namespace eval foo {namespace current}}] \
[namespace eval ::test_ns_5 \
{namespace eval ::test_ns_6 {namespace current}}] \
[lsort [namespace children :: test_ns_*]]
} {{} ::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4::foo ::test_ns_6 {::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4 ::test_ns_5 ::test_ns_6}}
test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} {
list [namespace eval :::test_ns_1::::foo {namespace current}] \
[namespace eval test_ns_2:::::foo {namespace current}]
} {::test_ns_1::foo ::test_ns_2::foo}
test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg
} {0 ::test_ns_7}
test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1:: {
namespace eval test_ns_2:: {}
namespace eval test_ns_3:: {}
}
lsort [namespace children ::test_ns_1]
} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_3}]
test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} {
set trigger {
namespace eval test_ns_2 {namespace current}
}
set l {}
lappend l [namespace eval test_ns_1 $trigger]
namespace eval test_ns_1::test_ns_2 {}
lappend l [namespace eval test_ns_1 $trigger]
} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2}
test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
return [namespace current]
}
}
list [test_ns_1::p] [catch {test_ns_1::p} msg] $msg
} {::test_ns_1 1 {invalid command name "test_ns_1::p"}}
test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} {
namespace eval test_ns_2 {
proc p {} {
return [namespace current]
}
}
list [test_ns_2::p] [namespace delete test_ns_2]
} {::test_ns_2 {}}
test namespace-7.3 {recursive Tcl_DeleteNamespace, active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
set x 1
trace add variable x unset "namespace delete [namespace current];#"
namespace delete [namespace current]
}
} {}
test namespace-7.4 {recursive Tcl_DeleteNamespace, active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
namespace delete [namespace current]
}
} {}
test namespace-7.5 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
set x 1
trace add variable x unset "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-7.7 {Bug 1655305} -setup {
interp create child
# Can't invoke through the ensemble, since deleting ::tcl
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 |
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_1 {
namespace export p
proc p {} {
return [namespace current]
}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::p
variable v 27
proc q {} {
variable v
return "[p] $v"
}
}
set x [test_ns_2::q]
catch {set xxxx}
}
list [interp eval test_interp {test_ns_2::q}] \
[interp eval test_interp {namespace delete ::}] \
[catch {interp eval test_interp {set a 123}} msg] $msg \
[interp delete test_interp]
} {{::test_ns_1 27} {} 1 {invalid command name "set"} {}}
test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
list [namespace children test_ns_1] \
[namespace delete test_ns_1::test_ns_2] \
[namespace children test_ns_1]
} {::test_ns_1::test_ns_2 {} {}}
test namespace-8.3 {TclTeardownNamespace, delete child namespaces} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
list [namespace children test_ns_1] \
[namespace delete test_ns_1::test_ns_2] \
[namespace children test_ns_1] \
[catch {namespace children test_ns_1::test_ns_2} msg] $msg \
[info commands test_ns_1::test_ns_2::test_ns_3a::*]
} {::test_ns_1::test_ns_2 {} {} 1 {namespace "test_ns_1::test_ns_2" not found in "::"} {}}
test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1 cmd2
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
proc p {} {return foo}
}
list [lsort [info commands test_ns_import::*]] \
[namespace delete test_ns_export] \
[info commands test_ns_import::*]
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p]
test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create child
child eval {trace add execution error leave {namespace delete :: ;#}}
catch {child eval error foo bar baz}
interp delete child
set ::errorInfo
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
} {1 {unknown namespace in import pattern "fred::x"}}
test namespace-9.3 {Tcl_Import, import ns == export ns} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg
} {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}}
test namespace-9.4 {Tcl_Import, simple import} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
| | | | | | | | | | | | | | | | | | | 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 |
} {1 {unknown namespace in import pattern "fred::x"}}
test namespace-9.3 {Tcl_Import, import ns == export ns} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg
} {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}}
test namespace-9.4 {Tcl_Import, simple import} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
proc p {} {return [cmd1 123]}
}
test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, RFE 1230597} -setup {
namespace eval test_ns_import {}
namespace eval test_ns_export {}
} -body {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} -result {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} -setup {
namespace eval test_ns_import {}
namespace eval ::test_ns_export {
proc cmd1 {args} {return "cmd1: $args"}
namespace export cmd1
}
} -body {
namespace eval test_ns_import {
namespace import -force ::test_ns_export::*
cmd1 555
}
} -result {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
namespace eval test_ns_import {
namespace import -force ::test_ns_export::*
}
list [test_ns_import::cmd1 a b c] \
[test_ns_export::cmd1 d e f] \
[proc test_ns_export::cmd1 {args} {return "new1: $args"}] \
[namespace origin test_ns_import::cmd1] \
[namespace origin test_ns_export::cmd1] \
[test_ns_import::cmd1 g h i] \
[test_ns_export::cmd1 j k l]
} {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}}
test namespace-9.8 {Tcl_Import: Bug 1017299} -setup {
namespace eval one {
namespace export cmd
proc cmd {} {}
}
namespace eval two {
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} {
namespace eval test_ns_export {
| | | | | | | | | | | | | | | | 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 |
test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} {
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_import {
namespace forget ::test_ns_export::wombat
}
} {}
test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} -setup {
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
} -body {
namespace eval test_ns_import {
namespace import ::test_ns_export::*
proc p {} {return [cmd1 123]}
set l {}
lappend l [lsort [info commands ::test_ns_import::*]]
namespace forget ::test_ns_export::cmd1
lappend l [info commands ::test_ns_import::*]
lappend l [catch {cmd1 777} msg] $msg
}
} -result [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}]
test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
|
| ︙ | ︙ | |||
599 600 601 602 603 604 605 |
namespace delete origin link link2 my
} -returnCodes error -match glob -result *
test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_export {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
namespace delete origin link link2 my
} -returnCodes error -match glob -result *
test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
list [namespace origin set] [namespace origin test_ns_export::cmd1]
} -result {::set ::test_ns_export::cmd1}
test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
} -body {
namespace eval test_ns_import1 {
namespace import ::test_ns_export::*
namespace export *
proc p {} {namespace origin cmd1}
}
list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1]
} -result {::test_ns_export::cmd1 ::test_ns_export::cmd1}
test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
namespace eval test_ns_import1 {
namespace import ::test_ns_export::*
namespace export *
proc p {} {namespace origin cmd1}
}
} -body {
namespace eval test_ns_import2 {
namespace import ::test_ns_import1::*
proc q {} {return [cmd1 123]}
}
list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1]
} -result {{cmd1: 123} ::test_ns_export::cmd1}
test namespace-12.1 {InvokeImportedCmd} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {namespace current}
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
}
list [test_ns_import::cmd1]
} {::test_ns_export}
test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {namespace current}
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
}
} -body {
namespace eval test_ns_import {
set l {}
lappend l [info commands ::test_ns_import::*]
namespace forget ::test_ns_export::cmd1
lappend l [info commands ::test_ns_import::*]
}
} -result {::test_ns_import::cmd1 {}}
test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} {
# Will panic if still buggy
namespace eval src {namespace export foo; proc foo {} {}}
namespace eval dst {namespace import [namespace parent]::src::foo}
trace add command src::foo delete \
"[list namespace delete [namespace current]::dst] ;#"
proc src::foo {} {}
namespace delete src
} {}
test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
}
namespace eval test_ns_2 {
variable v 30
}
} -body {
namespace eval test_ns_1 {
list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \
[lsort [namespace children :: test_ns_*]]
}
} -result [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]]
test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
}
namespace eval test_ns_2 {
variable v 30
}
} -body {
namespace eval test_ns_1 {
list [catch {set ::test_ns_777::v} msg] $msg \
[catch {namespace children test_ns_777} msg] $msg
}
} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}}
# TIP 278: secondary lookup disabled, results changed from {10 20}
test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
}
namespace eval test_ns_2 {
variable v 30
}
} -body {
namespace eval test_ns_1 {
# list $v $test_ns_2::v
list [catch {set v} msg] $msg [catch {set test_ns_2::v} msg] $msg
}
} -result {1 {can't read "v": no such variable} 0 20}
test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval test_ns_1::test_ns_2 {
namespace eval foo {}
}
namespace eval test_ns_1 {
list [namespace children test_ns_2] \
[catch {namespace children test_ns_1} msg] $msg
}
} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}}
test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval ::test_ns_2 {
namespace eval bar {}
}
namespace eval test_ns_1 {
list [catch {namespace delete test_ns_2::bar} msg] $msg
}
} {1 {unknown namespace "test_ns_2::bar" in namespace delete command}}
test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval test_ns_1::test_ns_2 {
namespace eval foo {}
}
namespace eval test_ns_1 {
list [namespace children test_ns_2] \
[catch {namespace children test_ns_1} msg] $msg
}
} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}}
test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup {
namespace eval test_ns_1::test_ns_2::foo {}
} -body {
namespace children test_ns_1:::
} -result {::test_ns_1::test_ns_2}
|
| ︙ | ︙ | |||
790 791 792 793 794 795 796 |
} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
# TIP 278: secondary lookup disabled, added catch, result changed from y
test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | | 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 |
} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
# TIP 278: secondary lookup disabled, added catch, result changed from y
test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
variable {}
catch {set test_ns_1::(x) y} ::msg
}
list $::msg [catch {set test_ns_1::(x)} msg] $msg
} -result {{can't set "test_ns_1::(x)": parent namespace doesn't exist} 1 {can't read "test_ns_1::(x)": no such variable}}
test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -returnCodes error -body {
namespace eval test_ns_1 {
proc {} {} {}
namespace eval {} {}
{}
}
} -result {can't create namespace "": only global namespace can have empty name}
test namespace-15.1 {Tcl_FindNamespace, absolute name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_delete {
namespace eval test_ns_delete2 {}
proc cmd {args} {namespace current}
}
list [namespace delete ::test_ns_delete::test_ns_delete2] \
[namespace children ::test_ns_delete]
} -result {{} {}}
test namespace-15.2 {Tcl_FindNamespace, absolute name not found} -body {
namespace delete ::test_ns_delete::test_ns_delete2
} -returnCodes error -result {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}
test namespace-15.3 {Tcl_FindNamespace, relative name found} {
namespace eval test_ns_delete {
namespace eval test_ns_delete2 {}
namespace eval test_ns_delete3 {}
list [namespace delete test_ns_delete2] \
[namespace children [namespace current]]
}
} {{} ::test_ns_delete::test_ns_delete3}
test namespace-15.4 {Tcl_FindNamespace, relative name not found} {
namespace eval test_ns_delete2 {}
namespace eval test_ns_delete {
list [catch {namespace delete test_ns_delete2} msg] $msg
}
} {1 {unknown namespace "test_ns_delete2" in namespace delete command}}
test namespace-16.1 {Tcl_FindCommand, absolute name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
proc cmd {args} {return "[namespace current]::cmd: $args"}
variable v "::test_ns_1::cmd"
eval $v one
}
} -result {::test_ns_1::cmd: one}
test namespace-16.2 {Tcl_FindCommand, absolute name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc cmd {args} {return "[namespace current]::cmd: $args"}
variable v "::test_ns_1::cmd"
}
} -body {
eval $test_ns_1::v two
} -result {::test_ns_1::cmd: two}
test namespace-16.3 {Tcl_FindCommand, absolute name not found} {
namespace eval test_ns_1 {
variable v2 "::test_ns_1::ladidah"
list [catch {eval $v2} msg] $msg
}
} {1 {invalid command name "::test_ns_1::ladidah"}}
# save the "unknown" proc, which is redefined by the following two tests
catch {rename unknown unknown.old}
proc unknown {args} {
return "unknown: $args"
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
# restore the "unknown" proc saved previously
catch {rename unknown {}}
catch {rename unknown.old unknown}
test namespace-16.8 {Tcl_FindCommand, relative name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# restore the "unknown" proc saved previously
catch {rename unknown {}}
catch {rename unknown.old unknown}
test namespace-16.8 {Tcl_FindCommand, relative name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc cmd {args} {return "[namespace current]::cmd: $args"}
}
} -body {
namespace eval test_ns_1 {
cmd a b c
}
} -result {::test_ns_1::cmd: a b c}
test namespace-16.9 {Tcl_FindCommand, relative name found} -body {
proc cmd2 {args} {return "[namespace current]::cmd2: $args"}
namespace eval test_ns_1 {
cmd2 a b c
}
} -cleanup {
catch {rename cmd2 {}}
} -result {::::cmd2: a b c}
test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} -body {
proc cmd2 {args} {return "[namespace current]::cmd2: $args"}
namespace eval test_ns_1 {
proc cmd2 {args} {
return "[namespace current]::cmd2 in test_ns_1: $args"
}
namespace eval test_ns_12 {
cmd2 a b c
}
}
} -cleanup {
catch {rename cmd2 {}}
} -result {::::cmd2: a b c}
test namespace-16.11 {Tcl_FindCommand, relative name not found} -body {
namespace eval test_ns_1 {
cmd3 a b c
}
} -returnCodes error -result {invalid command name "cmd3"}
unset -nocomplain x
test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
set x 314159
namespace eval test_ns_1 {
set ::x
}
} -result {314159}
variable ::x 314159
test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} {
namespace eval test_ns_1 {
variable x 777
set ::test_ns_1::x
}
} {777}
test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} {
namespace eval test_ns_1 {
namespace eval test_ns_2 {
variable x 1111
}
set ::test_ns_1::test_ns_2::x
}
} {1111}
test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} -body {
namespace eval test_ns_1 {
namespace eval test_ns_2 {
variable x 1111
}
set ::test_ns_1::test_ns_2::y
}
} -returnCodes error -result {can't read "::test_ns_1::test_ns_2::y": no such variable}
test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} -setup {
namespace eval ::test_ns_1::test_ns_2 {}
} -body {
namespace eval test_ns_1 {
namespace eval test_ns_3 {
variable ::test_ns_1::test_ns_2::x 2222
}
}
set ::test_ns_1::test_ns_2::x
} -result {2222}
test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup {
namespace eval test_ns_1 {
variable x 777
}
} -body {
namespace eval test_ns_1 {
set x
}
} -result {777}
# TIP 278: secondary lookup disabled, catch added, result changed from 314159
test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} {
namespace eval test_ns_1 {
variable x 777
unset x
list [catch {set x} msg] $msg ;# must not be global x now
}
} {1 {can't read "x": no such variable}}
test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body {
namespace eval test_ns_1 {
set wuzzat
}
} -returnCodes error -result {can't read "wuzzat": no such variable}
test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} {
namespace eval test_ns_1 {
variable a hello
}
set test_ns_1::a
} {hello}
# TIP 278: secondary lookup disabled, result changed from 1
test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup {
namespace eval test_ns_1 {}
|
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 |
catch {unset l}
catch {rename foo {}}
test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
proc foo {} {return "global foo"}
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | | | | | 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 |
catch {unset l}
catch {rename foo {}}
test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
proc foo {} {return "global foo"}
namespace eval test_ns_1 {
proc trigger {} {
return [foo]
}
}
set l ""
lappend l [test_ns_1::trigger]
namespace eval test_ns_1 {
# force invalidation of cached ref to "foo" in proc trigger
proc foo {} {return "foo in test_ns_1"}
}
lappend l [test_ns_1::trigger]
} -result {{global foo} {foo in test_ns_1}}
test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} {
namespace eval test_ns_2 {
proc foo {} {return "foo in ::test_ns_2"}
}
namespace eval test_ns_1 {
namespace eval test_ns_2 {}
proc trigger {} {
return [test_ns_2::foo]
}
}
set l ""
lappend l [test_ns_1::trigger]
namespace eval test_ns_1 {
namespace eval test_ns_2 {
# force invalidation of cached ref to "foo" in proc trigger
proc foo {} {return "foo in ::test_ns_1::test_ns_2"}
}
}
lappend l [test_ns_1::trigger]
} {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}}
catch {unset l}
catch {rename foo {}}
test namespace-19.1 {GetNamespaceFromObj, global name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1::test_ns_2 {}
namespace children ::test_ns_1
} -result {::test_ns_1::test_ns_2}
test namespace-19.2 {GetNamespaceFromObj, relative name found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
} -body {
namespace eval test_ns_1 {
namespace children test_ns_2
}
} -result {}
test namespace-19.3 {GetNamespaceFromObj, name not found} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
namespace children test_ns_99
}
} -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"}
test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
} -body {
namespace eval test_ns_1 {
proc foo {} {
return [namespace children test_ns_2]
}
list [catch {namespace children test_ns_99} msg] $msg
}
set l {}
lappend l [test_ns_1::foo]
namespace delete test_ns_1::test_ns_2
namespace eval test_ns_1::test_ns_2::test_ns_3 {}
lappend l [test_ns_1::foo]
} -result {{} ::test_ns_1::test_ns_2::test_ns_3}
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
expr {"::test_ns_1" in [namespace children]}
} -result {1}
test namespace-21.2 {NamespaceChildrenCmd, no args} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
} -body {
namespace eval test_ns_1 {
| | | | | 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 |
expr {"::test_ns_1" in [namespace children]}
} -result {1}
test namespace-21.2 {NamespaceChildrenCmd, no args} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
} -body {
namespace eval test_ns_1 {
namespace children
}
} -result {::test_ns_1::test_ns_2}
test namespace-21.3 {NamespaceChildrenCmd, ns name given} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
} -body {
namespace children ::test_ns_1
} -result {::test_ns_1::test_ns_2}
test namespace-21.4 {NamespaceChildrenCmd, ns name given} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
} -body {
namespace eval test_ns_1 {
namespace children test_ns_2
}
} -result {}
test namespace-21.5 {NamespaceChildrenCmd, too many args} {
namespace eval test_ns_1 {
list [catch {namespace children test_ns_2 xxx yyy} msg] $msg
}
} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}}
test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} {
namespace eval test_ns_1::test_ns_foo {}
namespace children test_ns_1 *f*
} {::test_ns_1::test_ns_foo}
test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} -setup {
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 |
namespace eval test_ns_1 {}
namespace children [namespace current] [fq test_ns_1]
} [fq test_ns_1]
test namespace-22.1 {NamespaceCodeCmd, bad args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace code} msg] $msg \
| | | | | 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 |
namespace eval test_ns_1 {}
namespace children [namespace current] [fq test_ns_1]
} [fq test_ns_1]
test namespace-22.1 {NamespaceCodeCmd, bad args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace code} msg] $msg \
[catch {namespace code xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}}
test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} {
namespace eval test_ns_1 {
proc cmd {} {return "test_ns_1::cmd"}
}
namespace code {::namespace inscope ::test_ns_1 cmd}
} {::namespace inscope ::test_ns_1 cmd}
test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} {
namespace code {namespace inscope ::test_ns_1 cmd}
} {::namespace inscope :: {namespace inscope ::test_ns_1 cmd}}
test namespace-22.4 {NamespaceCodeCmd, in :: namespace} {
namespace code unknown
} {::namespace inscope :: unknown}
test namespace-22.5 {NamespaceCodeCmd, in other namespace} {
namespace eval test_ns_1 {
namespace code cmd
}
} {::namespace inscope ::test_ns_1 cmd}
test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
namespace eval test_ns_1 {
variable v 42
}
namespace eval test_ns_2 {
|
| ︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 |
::namespace code {namespace inscope foo}
}
} [list ::namespace inscope [fq demo] {namespace inscope foo}]
test namespace-23.1 {NamespaceCurrentCmd, bad args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace current xxx} msg] $msg \
| | | | 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 |
::namespace code {namespace inscope foo}
}
} [list ::namespace inscope [fq demo] {namespace inscope foo}]
test namespace-23.1 {NamespaceCurrentCmd, bad args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace current xxx} msg] $msg \
[catch {namespace current xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}}
test namespace-23.2 {NamespaceCurrentCmd, at global level} {
namespace current
} {::}
test namespace-23.3 {NamespaceCurrentCmd, in nested ns} {
namespace eval test_ns_1::test_ns_2 {
namespace current
}
} {::test_ns_1::test_ns_2}
test namespace-24.1 {NamespaceDeleteCmd, no args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace delete
} {}
|
| ︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 |
test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
namespace test_ns_1
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
namespace eval test_ns_1 {
| | | | | | | | | | | | | 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 |
test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
namespace test_ns_1
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
namespace eval test_ns_1 {
variable v 314159
proc p {} {
variable v
return $v
}
}
test_ns_1::p
} {314159}
test namespace-25.4 {NamespaceEvalCmd, existing namespace} -setup {
namespace eval test_ns_1 {
variable v 314159
proc p {} {
variable v
return $v
}
}
} -body {
namespace eval test_ns_1 {
proc q {} {return [expr {[p]+1}]}
}
test_ns_1::q
} -result {314160}
test namespace-25.5 {NamespaceEvalCmd, multiple args} -setup {
namespace eval test_ns_1 {variable v 314159}
} -body {
namespace eval test_ns_1 "set" "v"
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 |
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
namespace export -clear
} {}
test namespace-26.3 {NamespaceExportCmd, pattern can't specify a namespace} {
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
namespace export -clear
} {}
test namespace-26.3 {NamespaceExportCmd, pattern can't specify a namespace} {
namespace eval test_ns_1 {
list [catch {namespace export ::zzz} msg] $msg
}
} {1 {invalid export pattern "::zzz": pattern can't specify a namespace}}
test namespace-26.4 {NamespaceExportCmd, one pattern} {
namespace eval test_ns_1 {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
}
list [info commands test_ns_2::*] [test_ns_2::cmd1 hello]
} {::test_ns_2::cmd1 {cmd1: hello}}
test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
namespace export cmd1 cmd3
}
} -body {
namespace eval test_ns_2 {
namespace import -force ::test_ns_1::*
}
list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello]
} -result {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}}
test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
namespace export cmd1 cmd3
}
} -body {
namespace eval test_ns_1 {
namespace export
}
} -result {cmd1 cmd3}
test namespace-26.7 {NamespaceExportCmd, -clear resets export list} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
}
} -body {
namespace eval test_ns_1 {
namespace export cmd1 cmd3
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
}
namespace eval test_ns_1 {
namespace export -clear cmd4
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
}
list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
} -result [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]
test namespace-26.8 {NamespaceExportCmd, -clear resets export list} {
catch {namespace delete foo}
namespace eval foo {
namespace export x
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 |
namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
list [catch {namespace forget ::test_ns_1::xxx} msg] $msg
} {1 {unknown namespace in namespace forget pattern "::test_ns_1::xxx"}}
test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} {
namespace eval test_ns_1 {
| | | | | | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 |
namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
list [catch {namespace forget ::test_ns_1::xxx} msg] $msg
} {1 {unknown namespace in namespace forget pattern "::test_ns_1::xxx"}}
test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} {
namespace eval test_ns_1 {
namespace export cmd*
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
namespace forget ::test_ns_1::cmd1
}
info commands ::test_ns_2::*
} {::test_ns_2::cmd2}
test namespace-28.1 {NamespaceImportCmd, no args} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -result {bar boo foo}
test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
namespace import -force
} {}
test namespace-28.3 {NamespaceImportCmd, arg is imported} {
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 |
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -result {bar boo foo}
test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
namespace import -force
} {}
test namespace-28.3 {NamespaceImportCmd, arg is imported} {
namespace eval test_ns_1 {
namespace export cmd2
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
namespace forget ::test_ns_1::cmd1
}
info commands test_ns_2::*
} {::test_ns_2::cmd2}
test namespace-29.1 {NamespaceInscopeCmd, bad args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace inscope} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
test namespace-29.2 {NamespaceInscopeCmd, bad args} {
list [catch {namespace inscope ::} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} -body {
namespace inscope test_ns_1 {set v}
} -returnCodes error -result {namespace "test_ns_1" not found in "::"}
test namespace-29.4 {NamespaceInscopeCmd, simple case} {
namespace eval test_ns_1 {
variable v 747
proc cmd {args} {
variable v
return "[namespace current]::cmd: v=$v, args=$args"
}
}
namespace inscope test_ns_1 cmd
} {::test_ns_1::cmd: v=747, args=}
test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} -setup {
namespace eval test_ns_1 {
variable v 747
proc cmd {args} {
variable v
return "[namespace current]::cmd: v=$v, args=$args"
}
}
} -body {
list [namespace inscope test_ns_1 cmd x y z] \
[namespace eval test_ns_1 [concat cmd [list x y z]]]
} -result {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}}
test namespace-29.6 {NamespaceInscopeCmd, 1400572} -setup {
namespace eval test_ns_1 {}
} -body {
namespace inscope test_ns_1 {info level 0}
} -result {namespace inscope test_ns_1 {info level 0}}
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
list [catch {namespace origin fred} msg] $msg
} {1 {invalid command name "fred"}}
test namespace-30.4 {NamespaceOriginCmd, command isn't imported} {
namespace origin set
} {::set}
test namespace-30.5 {NamespaceOriginCmd, imported command} {
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 |
list [catch {namespace origin fred} msg] $msg
} {1 {invalid command name "fred"}}
test namespace-30.4 {NamespaceOriginCmd, command isn't imported} {
namespace origin set
} {::set}
test namespace-30.5 {NamespaceOriginCmd, imported command} {
namespace eval test_ns_1 {
namespace export cmd*
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace export *
namespace import ::test_ns_1::*
proc p {} {}
}
namespace eval test_ns_3 {
namespace import ::test_ns_2::*
list [namespace origin foreach] \
[namespace origin p] \
[namespace origin cmd1] \
[namespace origin ::test_ns_2::cmd2]
}
} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2}
test namespace-31.1 {NamespaceParentCmd, bad args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace parent a b} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-31.2 {NamespaceParentCmd, no args} {
namespace parent
} {}
test namespace-31.3 {NamespaceParentCmd, namespace specified} {
namespace eval test_ns_1 {
namespace eval test_ns_2 {
namespace eval test_ns_3 {}
}
}
list [namespace parent ::] \
[namespace parent test_ns_1::test_ns_2] \
[namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}]
} {{} ::test_ns_1 ::test_ns_1}
test namespace-31.4 {NamespaceParentCmd, bad namespace specified} -body {
namespace parent test_ns_1::test_ns_foo
} -returnCodes error -result {namespace "test_ns_1::test_ns_foo" not found in "::"}
test namespace-32.1 {NamespaceQualifiersCmd, bad args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
1578 1579 1580 1581 1582 1583 1584 |
} {}
test namespace-34.4 {NamespaceWhichCmd, bad args} {
list [catch {namespace which a b} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.5 {NamespaceWhichCmd, command lookup} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} {}
test namespace-34.4 {NamespaceWhichCmd, bad args} {
list [catch {namespace which a b} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.5 {NamespaceWhichCmd, command lookup} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
namespace export cmd*
variable v1 111
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace export *
namespace import ::test_ns_1::*
variable v2 222
proc p {} {}
}
} -body {
namespace eval test_ns_3 {
namespace import ::test_ns_2::*
variable v3 333
list [namespace which -command foreach] \
[namespace which -command p] \
[namespace which -command cmd1] \
[namespace which -command ::test_ns_2::cmd2] \
[catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg
}
} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}}
test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
namespace export cmd*
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace export *
namespace import ::test_ns_1::*
proc p {} {}
}
namespace eval test_ns_3 {
namespace import ::test_ns_2::*
}
} -body {
namespace eval test_ns_3 {
list [namespace which foreach] \
[namespace which p] \
[namespace which cmd1] \
[namespace which ::test_ns_2::cmd2]
}
} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2}
# TIP 278: secondary lookup disabled, catch added, result changed
test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
namespace export cmd*
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace export *
namespace import ::test_ns_1::*
variable v2 222
proc p {} {}
}
namespace eval test_ns_3 {
variable v3 333
namespace import ::test_ns_2::*
}
} -body {
namespace eval test_ns_3 {
list [catch {namespace which -variable env } msg] $msg \
[namespace which -variable v3] \
[namespace which -variable ::test_ns_2::v2] \
[catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg
}
} -result {0 {} ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
return [namespace current]
}
}
test_ns_1::p
} -result {::test_ns_1}
test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} {
namespace eval test_ns_1 {
proc q {} {
return [namespace current]
}
}
list [test_ns_1::q] \
[namespace delete test_ns_1] \
[catch {test_ns_1::q} msg] $msg
} {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}}
catch {unset x}
catch {unset y}
test namespace-36.1 {DupNsNameInternalRep} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {}
set x "::test_ns_1"
list [namespace parent $x] [set y $x] [namespace parent $y]
} {:: ::test_ns_1 ::}
catch {unset x}
catch {unset y}
test namespace-37.1 {SetNsNameFromAny, ns name found} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
namespace eval test_ns_1 {
namespace children ::test_ns_1
}
} {::test_ns_1::test_ns_2}
test namespace-37.2 {SetNsNameFromAny, ns name not found} -body {
namespace eval test_ns_1 {
namespace children ::test_ns_1::test_ns_foo
}
} -returnCodes error -result {namespace "::test_ns_1::test_ns_foo" not found}
test namespace-38.1 {UpdateStringOfNsName} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name
list [namespace eval {} {namespace current}] \
[namespace eval {} {namespace current}]
} {:: ::}
test namespace-39.1 {NamespaceExistsCmd} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval ::test_ns_z::test_me { variable foo }
list [namespace exists ::] \
[namespace exists ::bogus_namespace] \
|
| ︙ | ︙ | |||
1923 1924 1925 1926 1927 1928 1929 |
test namespace-42.11 {
ensembles: prefix matching segmentation fault
issue ccc448a6bfd59cbd
} -body {
namespace eval n1 {
| | | | | 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 |
test namespace-42.11 {
ensembles: prefix matching segmentation fault
issue ccc448a6bfd59cbd
} -body {
namespace eval n1 {
namespace ensemble create
namespace export *
proc p1 args {error success}
}
# segmentation fault only occurs in the non-byte-compiled path, so avoid
# byte compilation
set cmd {namespace eva n1 {[namespace parent]::n1 p1}}
{*}$cmd
} -returnCodes error -result success
|
| ︙ | ︙ | |||
3247 3248 3249 3250 3251 3252 3253 |
0 {x1 x1 x1 x1 x1}}
test namespace-53.8 {ensemble: unknown handler changing -parameters} -setup {
namespace eval ns {
namespace export x*
proc x1 {a1} {list 1 $a1}
proc Magic {ensemble subcmd args} {
namespace ensemble configure $ensemble\
| | | | | | 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 |
0 {x1 x1 x1 x1 x1}}
test namespace-53.8 {ensemble: unknown handler changing -parameters} -setup {
namespace eval ns {
namespace export x*
proc x1 {a1} {list 1 $a1}
proc Magic {ensemble subcmd args} {
namespace ensemble configure $ensemble\
-parameters [lrange p1 [llength [
namespace ensemble configure $ensemble -parameters
]] 0]
list
}
namespace ensemble create -unknown ::ns::Magic
}
} -body {
set result {}
lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters]
lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters]
|
| ︙ | ︙ | |||
3272 3273 3274 3275 3276 3277 3278 |
test namespace-53.9 {ensemble: unknown handler changing -parameters,\
thereby eating all args} -setup {
namespace eval ns {
namespace export x*
proc x1 {args} {list 1 $args}
proc Magic {ensemble subcmd args} {
namespace ensemble configure $ensemble\
| | | | 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 |
test namespace-53.9 {ensemble: unknown handler changing -parameters,\
thereby eating all args} -setup {
namespace eval ns {
namespace export x*
proc x1 {args} {list 1 $args}
proc Magic {ensemble subcmd args} {
namespace ensemble configure $ensemble\
-parameters {p1 p2 p3 p4 p5}
list
}
namespace ensemble create -unknown ::ns::Magic
}
} -body {
set result {}
lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters]
lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters]
|
| ︙ | ︙ | |||
3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 |
rename getbytes {}
unset i ns start end
} -result 0
test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
info class [format %s constructor] oo::object
} ""
test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
namespace eval ::testing {
proc abc {} {}
proc def {} {}
trace add command abc delete "rename ::testing::def {}; #"
trace add command def delete "rename ::testing::abc {}; #"
| > > > > > > > > > > > > > > > > | 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 |
rename getbytes {}
unset i ns start end
} -result 0
test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
info class [format %s constructor] oo::object
} ""
test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-commands), bug [1095bf7f756f9aed]} -setup {
interp create -safe si
set code {
proc test_comp_dict d { dict for {k v} $d {expr $v} }
regexp -inline {Command 1:(?:[^\n]*\n){1,5}} [::tcl::unsupported::disassemble proc test_comp_dict]
}
} -body {
set a [ eval $code]
set b [si eval $code]
list [expr {$a eq $b}] [regexp { dictFirst } $a] [regexp { dictFirst } $b] $a $b
} -cleanup {
rename test_comp_dict {}
unset -nocomplain code a b
interp delete si
} -match glob -result {1 1 1 *}
test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
namespace eval ::testing {
proc abc {} {}
proc def {} {}
trace add command abc delete "rename ::testing::def {}; #"
trace add command def delete "rename ::testing::abc {}; #"
|
| ︙ | ︙ |
Changes to tests/obj.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
| < | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
bytecode
cmdName
dict
regexp
string
} {
set first [string first $t [testobj types]]
set r [expr {$r && ($first >= 0)}]
}
set result $r
} {1}
test obj-2.1 {Tcl_GetObjType error} testobj {
list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg
} {0 1 {no type foo found}}
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
lappend result [testdoubleobj set 1 3.14159]
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
lappend result [testobj type 1]
} {3.14159 0 int}
test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj {
set result ""
foreach s {yes no true false on off} {
| | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
lappend result [testdoubleobj set 1 3.14159]
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
lappend result [testobj type 1]
} {3.14159 0 int}
test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj {
set result ""
foreach s {yes no true false on off} {
teststringobj set 1 $s
lappend result [testbooleanobj not 1]
}
lappend result [testobj type 1]
} {0 1 0 1 0 1 int}
test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} testobj {
set result ""
lappend result [testintobj set 1 456]
lappend result [testintobj div10 1]
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
set x {}
for {set i 0} {$i<100000} {incr i} {
set x [list $x {}]
}
unset x
} {}
| | | | | | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
set x {}
for {set i 0} {$i<100000} {incr i} {
set x [list $x {}]
}
unset x
} {}
test obj-33.1 {integer overflow on input} {wideIs64bit} {
set x 0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {wideIs64bit} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 4294967296}
test obj-33.4 {integer overflow on input} {wideIs64bit} {
set x -0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {wideIs64bit} {
set x -0x8000; append x 0001
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {wideIs64bit} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {
set x -0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967296}
|
| ︙ | ︙ |
Changes to tests/oo.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
# this test suite, interp creation and interp deletion are often used in
# leaktests in order to leverage this sensitivity.
testConstraint memory [llength [info commands memory]]
| > > > > > > > > > > > > > > | 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 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# A helper for intercepting background errors
proc ::bgerrorIntercept {varName body} {
set old [interp bgerror {}]
interp bgerror {} [list apply {{var msg args} {
upvar #0 $var v
lappend v $msg
}} $varName]
try {
uplevel 1 $body
} finally {
interp bgerror {} $old
}
}
# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
# this test suite, interp creation and interp deletion are often used in
# leaktests in order to leverage this sensitivity.
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
package require tcl::oo
namespace delete ::
}
interp delete $i
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
| | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
package require tcl::oo
namespace delete ::
}
interp delete $i
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
[oo::object new] destroy
}
} -constraints memory -result 0
test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
oo::class create foo
foo new
foo destroy
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
lappend x [info object class $initial]
}
return $x
}] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
test oo-2.1 {basic test of OO functionality: constructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
# we're modifying the root object class's constructor
interp create subinterp
subinterp eval {
package require tcl::oo
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
lappend x [info object class $initial]
}
return $x
}] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
test oo-1.22 {basic test of OO functionality: nested ownership destruction order} -setup {
oo::class create parent
} -body {
oo::class create abc {
superclass parent
variable n
constructor {} {set n 0}
method make {i} {set n $i; [self class] create xyz}
destructor {lappend ::deathOrder $n}
}
apply {n {
set ::deathOrder {}
# Make some "nested" objects
set base [abc new]
for {set i 1; set obj $base} {$i < $n} {incr i} {
set obj [$obj make $i]
}
# Kill them all in one go; should come apart in right order!
$base destroy
return $::deathOrder
}} 5
} -cleanup {
parent destroy
} -result {1 2 3 4 0}
test oo-1.23 {basic test of OO functionality: deep nested ownership} -setup {
oo::class create parent
} -constraints knownBug -body {
oo::class create abc {
superclass parent
method make {} {[self class] create xyz}
destructor {incr ::count}
}
apply {n {
set ::count 0
# Make a lot of "nested" objects
set base [abc new]
for {set i 1; set obj $base} {$i < $n} {incr i} {
set obj [$obj make]
}
# Kill them all in one go; should not crash!
$base destroy
return [expr {$n - $::count}]
}} 10000
} -cleanup {
parent destroy
} -result 0
test oo-1.24 {basic test of OO functionality: deep nested ownership} -setup {
oo::class create parent
} -constraints knownBug -body {
oo::class create abc {
superclass parent
self method make {} {oo::copy [self] xyz}
}
apply {n {
# Make a lot of "nested" objects
set base abc
lappend lst $base [info object namespace $base]
for {set i 1; set obj $base} {$i < $n} {incr i} {
set obj [$obj make]
lappend lst $obj [info object namespace $obj]
}
# Kill them all in one go; should not crash!
$base destroy
# How many classes still there (cnt must remain 0)
set cnt 0
foreach {obj ns} $lst {
if {[namespace which -command $obj] ne "" || [namespace exists $ns]} {
incr cnt
}
}
return $cnt
}} 10000
} -cleanup {
parent destroy
} -result 0
test oo-1.25 {basic test of OO functionality: touch method after instance deletion, bug [0b809cd3fc8b6e5e]} -body {
set ::result {}
# test for eval and deletion of coro, in both cases the coroutine shall be deleted
foreach v {"eval" "del"} {
# 1st (deleted class)
oo::class create A
oo::define A method retard-it {} {yield}
coroutine tcoro [A new] retard-it
trace add command tcoro delete {apply {{args} {lappend ::result D}}}
A destroy
if {$v eq "eval"} { tcoro } else { rename tcoro {} }
# 2nd (deleted object of class)
oo::class create A
oo::define A method retard-it {} {yield}
set obj [A new]
coroutine tcoro $obj retard-it
trace add command tcoro delete {apply {{args} {lappend ::result D}}}
$obj destroy
if {$v eq "eval"} { tcoro } else { rename tcoro {} }
A destroy
# 3rd (deleted object)
set obj [oo::object new]
oo::objdefine $obj method retard-it {} {yield}
coroutine tcoro $obj retard-it
trace add command tcoro delete {apply {{args} {lappend ::result D}}}
$obj destroy
if {$v eq "eval"} { tcoro } else { rename tcoro {} }
}
set ::result
} -result [lrepeat 6 D]
test oo-2.1 {basic test of OO functionality: constructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
# we're modifying the root object class's constructor
interp create subinterp
subinterp eval {
package require tcl::oo
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
cls destroy
} -body {
oo::define cls destructor {error foo}
list [catch {[cls create obj] destroy} msg] $msg [info commands obj]
} -result {1 foo {}}
test oo-3.7 {basic test of OO functionality: errors in destructor} -setup {
oo::class create cls
| < < < > | > > | > | < < < > > | > | > | | 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 |
cls destroy
} -body {
oo::define cls destructor {error foo}
list [catch {[cls create obj] destroy} msg] $msg [info commands obj]
} -result {1 foo {}}
test oo-3.7 {basic test of OO functionality: errors in destructor} -setup {
oo::class create cls
} -cleanup {
cls destroy
} -body {
oo::define cls destructor {error foo}
bgerrorIntercept result {
set result [cls create obj]
lappend result [rename obj {}]
update idletasks
lappend result [info commands obj]
}
} -result {::obj {} foo {}}
test oo-3.8 {basic test of OO functionality: errors in destructor} -setup {
oo::class create cls
} -cleanup {
cls destroy
} -body {
oo::define cls destructor {error foo}
bgerrorIntercept result {
set result [cls create obj]
lappend result [namespace delete [info object namespace obj]]
update idletasks
lappend result [info commands obj]
}
} -result {::obj {} foo {}}
test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup {
oo::class create cls
set result {}
} -body {
oo::define cls {
destructor {
lappend ::result in destructor
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 |
oo::class create spong {superclass boo}
return
}
} -result {}
test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup {
set ::result ""
oo::class create c1 {
| | | | | | | | | | | | | | | | | | 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 |
oo::class create spong {superclass boo}
return
}
} -result {}
test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup {
set ::result ""
oo::class create c1 {
method m1 {} {
lappend ::result c1::m1
}
}
oo::class create c2 {
superclass c1
destructor {
lappend ::result c2::destructor
my m1
lappend ::result /c2::destructor
}
method m1 {} {
lappend ::result c2::m1
rename [self] {}
lappend ::result no-self
next
lappend ::result /c2::m1
}
}
} -body {
c2 create o
lappend ::result [catch {o m1} msg] $msg
} -cleanup {
c1 destroy
unset ::result
|
| ︙ | ︙ | |||
1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 |
# No segmentation fault
return done
} -result done -cleanup {
rename obj1 {}
}
test oo-12.1 {OO: filters} {
oo::class create Aclass
Aclass create Aobject
oo::define Aclass {
method concatenate args {
global result
lappend result {*}$args
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# No segmentation fault
return done
} -result done -cleanup {
rename obj1 {}
}
test oo-11.7 {Bug 154f0982f2: createWithNamespace and an existing namespace} -setup {
oo::class create Aclass {
self export createWithNamespace
method ns {} {namespace current}
}
} -body {
namespace eval test_oo117 {variable name [namespace current]}
list [Aclass createWithNamespace aInstance $test_oo117::name] [aInstance ns]
} -returnCodes error -cleanup {
Aclass destroy
catch {namespace delete test_oo117}
} -result {can't create namespace "::test_oo117": already exists}
test oo-11.8 {Bug 708422: unset traces in deletion shouldn't crash} -setup {
oo::class create foo {
self export createWithNamespace
method dummy {} {}
}
set result {}
} -body {
oo::define foo {
variable x
constructor {} {
trace add variable x unset [list apply {{self ns args} {
global result
lappend result [info object isa object $self]
lappend result [namespace exists $ns]
# Method dispatch fails; too much gone in this case
catch {$self dummy} msg
lappend result $msg
}} [self] [self namespace]]
}
}
[foo createWithNamespace bar oo-11.8] destroy
return $result
} -cleanup {
foo destroy
} -result {1 0 {impossible to invoke method "dummy": no defined method or unknown method}}
test oo-12.1 {OO: filters} {
oo::class create Aclass
Aclass create Aobject
oo::define Aclass {
method concatenate args {
global result
lappend result {*}$args
|
| ︙ | ︙ | |||
2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 |
c create o
} -body {
lsort [info object methods o -all -private]
} -cleanup {
o destroy
c destroy
} -result $stdmethods
test oo-18.1 {OO: define command support} {
list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
} {1 foo {foo
while executing
"error foo"
| > > > > > > > > > > > > > > > > > > > > > > > > | 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 |
c create o
} -body {
lsort [info object methods o -all -private]
} -cleanup {
o destroy
c destroy
} -result $stdmethods
test oo-17.15 {OO: class method list without -all (bug 36e5517a6850)} -setup {
oo::class create c
} -body {
oo::define c {
method foo {} {}
method Bar {} {}
private method gorp {} {}
}
list [lsort [info class methods c]] [lsort [info class methods c -private]]
} -cleanup {
c destroy
} -result {foo {Bar foo}}
test oo-17.16 {OO: instance method list without -all (bug 36e5517a6850)} -setup {
oo::object create o
} -body {
oo::objdefine o {
method foo {} {}
method Bar {} {}
private method gorp {} {}
}
list [lsort [info object methods o]] [lsort [info object methods o -private]]
} -cleanup {
o destroy
} -result {foo {Bar foo}}
test oo-18.1 {OO: define command support} {
list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
} {1 foo {foo
while executing
"error foo"
|
| ︙ | ︙ | |||
2938 2939 2940 2941 2942 2943 2944 |
"self {error foobar}"
(in definition script for class "::bar" line 1)
invoked from within
"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
test oo-18.9 {OO: define/self command support} -setup {
oo::class create parent
set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
| | | 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 |
"self {error foobar}"
(in definition script for class "::bar" line 1)
invoked from within
"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
test oo-18.9 {OO: define/self command support} -setup {
oo::class create parent
set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
superclass parent
}]
} -body {
catch {oo::define $c {error err}} msg opt
dict get $opt -errorinfo
} -cleanup {
parent destroy
} -result {err
|
| ︙ | ︙ | |||
2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 |
parent destroy
} -result {this command cannot be called when the object has been deleted
while executing
"self {error foobar}"
(in definition script for class "::foo" line 1)
invoked from within
"oo::define foo {rename ::foo {}; self {error foobar}}"}
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
oo::objdefine inst export eval
set result {}
inst eval { variable x }
} -body {
| > > > > > > > > > > | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 |
parent destroy
} -result {this command cannot be called when the object has been deleted
while executing
"self {error foobar}"
(in definition script for class "::foo" line 1)
invoked from within
"oo::define foo {rename ::foo {}; self {error foobar}}"}
test oo-18.12 {OO: self callable via eval method} -setup {
oo::class create parent {
export eval
}
parent create ::foo
} -body {
foo eval { self }
} -cleanup {
parent destroy
} -result ::foo
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
oo::objdefine inst export eval
set result {}
inst eval { variable x }
} -body {
|
| ︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 |
} -body {
testClass create A
testClass create B
lsearch [list [A varname foo] [B varname foo]] [B bar A]
} -cleanup {
testClass destroy
} -result 0
test oo-20.1 {OO: variable method} -body {
oo::class create testClass {
constructor {} {
my variable ok
set ok {}
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > | 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 |
} -body {
testClass create A
testClass create B
lsearch [list [A varname foo] [B varname foo]] [B bar A]
} -cleanup {
testClass destroy
} -result 0
test oo-19.4 {OO: varname ghosts [Bug 74b6110204]} -setup {
oo::class create testClass {
export varname
self export createWithNamespace
}
set obj [testClass createWithNamespace testoo19_4 testoo19_4]
set ns [info object namespace $obj]
} -body {
set v [$obj varname foo]
list [namespace which -variable $v] \
[info exists $v] [namespace which -variable $v]
} -cleanup {
testClass destroy
} -result {::testoo19_4::foo 0 ::testoo19_4::foo}
test oo-19.5 {OO: varname array elements [Bug 2da1cb0c80]} -setup {
set obj [oo::object new]
oo::objdefine $obj export eval varname
} -body {
$obj eval {
namespace upvar :: tcl_platform(platform) foo
}
$obj varname foo
} -cleanup {
$obj destroy
} -result ::tcl_platform(platform)
# Test oo-19.5.1 is no longer relevant
test oo-20.1 {OO: variable method} -body {
oo::class create testClass {
constructor {} {
my variable ok
set ok {}
}
|
| ︙ | ︙ | |||
3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 |
lsort {q w e r t y u i o p}; # Overwrite the Tcl stack
info frame 0
}
[c new] test
} -match glob -cleanup {
c destroy
} -result {* cmd {info frame 0} method test class ::c level 0}
# Prove that the issue in [Bug 1865054] isn't an issue any more
test oo-23.1 {Self-like derivation; complex case!} -setup {
oo::class create SELF {
superclass oo::class
unexport create new
# Next is just a convenience
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 |
lsort {q w e r t y u i o p}; # Overwrite the Tcl stack
info frame 0
}
[c new] test
} -match glob -cleanup {
c destroy
} -result {* cmd {info frame 0} method test class ::c level 0}
# Common code for oo-22.{3,4,5,6}
oo::class create WorkerBase
oo::class create WorkerSupport {
superclass oo::class WorkerBase
variable result stop
method WithWorkers {nworkers args script} {
set workers {}
try {
for {set n 1} {$n <= $nworkers} {incr n} {
lappend workers [set worker [[self] new]]
$worker schedule {*}$args
}
return [uplevel 1 $script]
} finally {
foreach worker $workers {$worker destroy}
}
}
method run {nworkers} {
set result {}
set stopvar [my varname stop]
set stop false
my WithWorkers $nworkers [list my Work [my varname result]] {
after idle [namespace code {set stop true}]
vwait $stopvar
}
return $result
}
}
oo::class create Worker {
superclass WorkerBase
method schedule {args} {
set coro [namespace current]::coro
if {![llength [info commands $coro]]} {
coroutine $coro {*}$args
}
}
method Work args {error unimplemented}
method dump {} {
info frame [expr {[info frame] - 1}]
}
}
test oo-22.3 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
# Triggers a crash with incorrectly restored pmPtr->procPtr->cmdPtr
WorkerSupport create A {
superclass Worker
method Work {var} {
after 0 [info coroutine]
yield
lappend $var [my dump]
}
}
A run 2
} -cleanup {
catch {rename dump {}}
catch {A destroy}
} -match glob -result {{* method Work class ::A *} {* method Work class ::A *}}
test oo-22.4 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
# Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr
WorkerSupport create A {
superclass Worker
method Work {var} {
after 0 [info coroutine]
yield
lappend $var [my dump]
}
}
# Copies the methods, changing the declarer
# Test it works with the source class still around
oo::copy A B
B run 2
} -cleanup {
catch {rename dump {}}
catch {A destroy}
catch {B destroy}
} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}}
test oo-22.5 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
# Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr
WorkerSupport create A {
superclass Worker
method Work {var} {
after 0 [info coroutine]
yield
lappend $var [my dump]
}
}
# Copies the methods, changing the declarer
# Test it works with the source class deleted
oo::copy A B
catch {A destroy}
B run 2
} -cleanup {
catch {rename dump {}}
catch {B destroy}
} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}}
test oo-22.6 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
# Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr
WorkerSupport create A {
superclass Worker
method Work {var} {
after 0 [info coroutine]
yield
lappend $var [my dump]
}
}
# Copies the methods, changing the declarer
# Test it works in the original source class with the copy around
oo::copy A B
B run 2
A run 2
} -cleanup {
catch {rename dump {}}
catch {A destroy}
catch {B destroy}
} -match glob -result {{* method Work class ::A *} {* method Work class ::A *}}
WorkerBase destroy
test oo-22.7 {oo::define and info frame: correct argument line} -setup {
oo::class create C {
variable base
constructor {info} {set base [dict get $info line]}
method Relative {} {
set info [next]
if {![dict exists $info file]} {
error "no file-relative line info: $info"
}
expr {[dict get $info line] - $base}
}
filter Relative
}
} -body {
C create o [info frame 0]
oo::define C {
method line1 {} {info frame 0}
method line2 {
} {info frame 0}
method line3 {
} {
info frame 0
}
}
oo::define C method line4 {} {info frame 0}
oo::define C method line5 {
} {info frame 0}
oo::define C method line6 {
} {
info frame 0
}
list [o line1] [o line2] [o line3] [o line4] [o line5] [o line6]
} -cleanup {
C destroy
} -result {2 4 7 10 12 15}
test oo-22.8 {oo::objdefine and info frame: correct argument line} -setup {
oo::class create C {
variable base
constructor {info} {set base [dict get $info line]}
method Relative {} {
set info [next]
if {![dict exists $info file]} {
error "no file-relative line info: $info"
}
expr {[dict get $info line] - $base}
}
filter Relative
}
} -body {
C create o [info frame 0]
oo::objdefine o {
method line1 {} {info frame 0}
method line2 {
} {info frame 0}
method line3 {
} {
info frame 0
}
}
oo::objdefine o method line4 {} {info frame 0}
oo::objdefine o method line5 {
} {info frame 0}
oo::objdefine o method line6 {
} {
info frame 0
}
list [o line1] [o line2] [o line3] [o line4] [o line5] [o line6]
} -cleanup {
C destroy
} -result {2 4 7 10 12 15}
# Prove that the issue in [Bug 1865054] isn't an issue any more
test oo-23.1 {Self-like derivation; complex case!} -setup {
oo::class create SELF {
superclass oo::class
unexport create new
# Next is just a convenience
|
| ︙ | ︙ | |||
3657 3658 3659 3660 3661 3662 3663 |
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
foo create bar
oo::objdefine bar {
variable y!
| | | 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 |
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
foo create bar
oo::objdefine bar {
variable y!
method y {} {list [next] [incr y!] [info var] [info locals]}
export eval
}
bar y
list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}]
} -result {{3 2 y! {}} {x! y!} {x! y!}}
test oo-27.7 {variables declaration - one underlying variable space} -setup {
oo::class create parent
|
| ︙ | ︙ | |||
4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 |
rename obj2 {}
rename obj1 {}
# doesn't crash
return done
} -cleanup {
rename obj {}
} -result done
test oo-36.1 {TIP #470: introspection within oo::define} {
oo::define oo::object self
} ::oo::object
test oo-36.2 {TIP #470: introspection within oo::define} -setup {
oo::class create Cls
} -body {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 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 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 |
rename obj2 {}
rename obj1 {}
# doesn't crash
return done
} -cleanup {
rename obj {}
} -result done
test oo-35.7.1 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
oo::class create base
oo::class create RpcClient {
superclass base
method write name {
lappend ::result "RpcClient -> $name"
}
method create_bug {} {
MkObjectRpc create cfg [self] 111
}
}
oo::class create MkObjectRpc {
superclass base
variable hdl
constructor {rpcHdl mqHdl} {
set hdl $mqHdl
oo::objdefine [self] forward rpc $rpcHdl
}
destructor {
my rpc write otto-$hdl
}
}
set ::result {}
} -body {
# In this case, sub-objects are deleted during major object NS cleanup and
# are trying to call back into the major object (which is mostky gone at
# this point). Things are messy; error is reported via bgerror as the
# avenue most likely to reach a user.
bgerrorIntercept ::result {
set FH [RpcClient new]
$FH create_bug
$FH destroy
update
}
join $result \n
} -cleanup {
base destroy
} -result {impossible to invoke method "write": no defined method or unknown method}
test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
oo::class create base
oo::class create RpcClient {
superclass base
method write name {
lappend ::result "RpcClient -> $name"
}
method create_bug {} {
MkObjectRpc create cfg [self] 111
}
destructor {
lappend ::result "Destroyed"
}
}
oo::class create MkObjectRpc {
superclass base
variable hdl
constructor {rpcHdl mqHdl} {
set hdl $mqHdl
oo::objdefine [self] forward rpc $rpcHdl
}
destructor {
my rpc write otto-$hdl
}
}
set ::result {}
} -body {
# In this case, sub-objects are deleted during major object NS cleanup, and
# we've a destructor on the major class to monitor when it happens. Things
# are still messy, but the order is clear; error is reported via bgerror as
# the avenue most likely to reach a user.
bgerrorIntercept ::result {
set FH [RpcClient new]
$FH create_bug
$FH destroy
update
}
join $result \n
} -cleanup {
base destroy
} -result {Destroyed
impossible to invoke method "write": no defined method or unknown method}
test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
oo::class create base
oo::class create RpcClient {
superclass base
variable interiorObjects
method write name {
lappend ::result "RpcClient -> $name"
}
method create_bug {} {
set obj [MkObjectRpc create cfg [self] 111]
lappend interiorObjects $obj
return $obj
}
destructor {
lappend ::result "Destroyed"
# Explicit destroy of interior objects
foreach obj $interiorObjects {
$obj destroy
}
}
}
oo::class create MkObjectRpc {
superclass base
variable hdl
constructor {rpcHdl mqHdl} {
set hdl $mqHdl
oo::objdefine [self] forward rpc $rpcHdl
}
destructor {
my rpc write otto-$hdl
}
}
set ::result {}
} -body {
# In this case, sub-objects are deleted while the destructor is running and
# the destroy is neat, so things work sanely. Error follows standard Tcl
# error flow route; bgerror is not used.
bgerrorIntercept ::result {
set FH [RpcClient new]
$FH create_bug
$FH destroy
update
}
join $result \n
} -cleanup {
base destroy
} -result "Destroyed\nRpcClient -> otto-111"
test oo-36.1 {TIP #470: introspection within oo::define} {
oo::define oo::object self
} ::oo::object
test oo-36.2 {TIP #470: introspection within oo::define} -setup {
oo::class create Cls
} -body {
|
| ︙ | ︙ | |||
5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 |
[oo::define foo definitionnamespace -instance {}] \
[info class definitionnamespace foo -instance]
} -cleanup {
parent destroy
namespace delete foodef
} -result {{} {} ::foodef {} {}}
cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > | 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 |
[oo::define foo definitionnamespace -instance {}] \
[info class definitionnamespace foo -instance]
} -cleanup {
parent destroy
namespace delete foodef
} -result {{} {} ::foodef {} {}}
rename bgerrorIntercept {}
cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/ooProp.test.
| ︙ | ︙ | |||
236 237 238 239 240 241 242 |
oo::class create parent
unset -nocomplain result
set result {}
} -body {
oo::configurable create Point {
superclass parent
property x y
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
oo::class create parent
unset -nocomplain result
set result {}
} -body {
oo::configurable create Point {
superclass parent
property x y
constructor args {
my configure -x 0 -y 0 {*}$args
}
variable x y
method report {} {
lappend ::result "x=$x, y=$y"
}
}
set pt [Point new -x 3]
$pt report
$pt configure -y 4
$pt report
lappend result [$pt configure -x],[$pt configure -y] [$pt configure]
} -cleanup {
parent destroy
} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}}
test ooProp-2.2 {TIP 558: properties: configurable class system} -setup {
oo::class create parent
} -body {
oo::configurable create Point {
superclass parent
property x y
constructor args {
my configure -x 0 -y 0 {*}$args
}
}
oo::configurable create 3DPoint {
superclass Point
property z
constructor args {
next -z 0 {*}$args
}
}
set pt [3DPoint new -x 3 -y 4 -z 5]
list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
[$pt configure]
} -cleanup {
parent destroy
} -result {3,4,5 {-x 3 -y 4 -z 5}}
test ooProp-2.3 {TIP 558: properties: configurable class system} -setup {
oo::class create parent
} -body {
oo::configurable create Point {
superclass parent
property x y
constructor args {
my configure -x 0 -y 0 {*}$args
}
}
set pt [Point new -x 3 -y 4]
oo::objdefine $pt property z
$pt configure -z 5
list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
[$pt configure]
} -cleanup {
parent destroy
} -result {3,4,5 {-x 3 -y 4 -z 5}}
test ooProp-2.4 {TIP 558: properties: configurable class system} -setup {
oo::class create parent
} -body {
oo::configurable create Point {
superclass parent
property x y
constructor args {
my configure -x 0 -y 0 {*}$args
}
}
[Point new] configure gorp
} -returnCodes error -cleanup {
parent destroy
} -result {bad property "gorp": must be -x or -y}
test ooProp-2.5 {TIP 558: properties: configurable class system} -setup {
oo::class create parent
} -body {
oo::configurable create Point {
superclass parent
property x y
constructor args {
my configure -x 0 -y 0 {*}$args
}
}
oo::configurable create 3DPoint {
superclass Point
property z
constructor args {
next -z 0 {*}$args
}
}
[3DPoint new] configure gorp
} -returnCodes error -cleanup {
parent destroy
} -result {bad property "gorp": must be -x, -y, or -z}
test ooProp-2.6 {TIP 558: properties: configurable class system} -setup {
oo::class create parent
} -body {
oo::configurable create Point {
superclass parent
property x y
constructor args {
my configure -x 0 -y 0 {*}$args
}
}
[Point create p] configure -x 1 -y
} -returnCodes error -cleanup {
parent destroy
} -result {wrong # args: should be "::p configure ?-option value ...?"}
test ooProp-2.7 {TIP 558: properties: configurable class system} -setup {
oo::class create parent
unset -nocomplain msg
} -body {
oo::configurable create Point {
superclass parent
property x y -kind writable
constructor args {
my configure -x 0 -y 0 {*}$args
}
}
Point create p
list [p configure -y ok] [catch {p configure -y} msg] $msg
} -cleanup {
parent destroy
} -result {{} 1 {property "-y" is write only}}
test ooProp-2.8 {TIP 558: properties: configurable class system} -setup {
oo::class create parent
unset -nocomplain msg
} -body {
oo::configurable create Point {
superclass parent
property x y -kind readable
constructor args {
my configure -x 0 {*}$args
variable y 123
}
}
Point create p
list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg
} -cleanup {
parent destroy
} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}}
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
} -cleanup {
parent destroy
} -result {1 {bad property name "-x": must not begin with -
while executing
"property -x"
(in definition script for class "::Point" line 1)
invoked from within
| | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 |
} -cleanup {
parent destroy
} -result {1 {bad property name "-x": must not begin with -
while executing
"property -x"
(in definition script for class "::Point" line 1)
invoked from within
"oo::define Point {property -x}"} {TCL OO PROPERTY_FORMAT}}
test ooProp-4.2 {TIP 558: properties: error details} -setup {
oo::class create parent
unset -nocomplain msg opt
} -body {
oo::configurable create Point {superclass parent}
list [catch {oo::define Point {property x -get}} msg opt] \
[dict get $opt -errorinfo] [dict get $opt -errorcode]
|
| ︙ | ︙ |
Changes to tests/ooUtil.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
}
test ooUtil-1.1 {TIP 478: classmethod} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
| | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
}
test ooUtil-1.1 {TIP 478: classmethod} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
Table find foo bar
} -cleanup {
parent destroy
} -result {::Table called with arguments: foo bar}
test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup {
namespace eval ::testns {}
|
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
} -cleanup {
namespace delete ::testns
} -result {::testns::Table called with arguments: foo bar}
test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
oo::class create parent
} -body {
oo::class create TestClass {
| | | | | | | | | | | | | | | | | | | | | | 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 |
} -cleanup {
namespace delete ::testns
} -result {::testns::Table called with arguments: foo bar}
test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
oo::class create parent
} -body {
oo::class create TestClass {
superclass oo::class parent
self method create {name ignore body} {
next $name $body
}
}
TestClass create okay {} {}
} -cleanup {
parent destroy
} -result {::okay}
test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
oo::class create SubTable {
superclass Table
}
SubTable find foo bar
} -cleanup {
parent destroy
} -result {::SubTable called with arguments: foo bar}
test ooUtil-1.5 {TIP 478: classmethod and instances} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
set t [Table new]
$t find 1 2 3
} -cleanup {
parent destroy
} -result {::Table called with arguments: 1 2 3}
test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
superclass parent
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
unexport find
}
set t [Table new]
$t find 1 2 3
} -returnCodes error -cleanup {
parent destroy
} -match glob -result {unknown method "find": must be *}
test ooUtil-1.7 {} -setup {
oo::class create parent
} -body {
oo::class create Foo {
superclass parent
classmethod bar {} {
puts "This is in the class; self is [self]"
my meee
}
classmethod meee {} {
puts "This is meee"
}
}
oo::class create Grill {
superclass Foo
classmethod meee {} {
puts "This is meee 2"
}
}
list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
} -cleanup {
parent destroy
} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
# Two tests to confirm that we correctly initialise the scripted part of TclOO
# in child interpreters. This is slightly tricky at the implementation level
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
}
# This is confirming that this is a (basic) safe interpreter
list [Table find foo bar] [info commands source]
}
} -cleanup {
interp delete $safeinterp
} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-2.1 {TIP 478: callback generation} -setup {
oo::class create parent
} -body {
oo::class create c {
superclass parent
method CallMe {} { return ok,[self] }
| > > > > > > > > > > > > | 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 |
}
# This is confirming that this is a (basic) safe interpreter
list [Table find foo bar] [info commands source]
}
} -cleanup {
interp delete $safeinterp
} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-1.10.1 {Bug 680503: classmethod shouldn't require create body} -body {
oo::class create C
oo::define C {classmethod cm {} {}}
} -cleanup {
catch {C destroy}
} -result {}
test ooUtil-1.10.2 {Bug 680503: case that worked} -body {
oo::class create C {}
oo::define C {classmethod cm {} {}}
} -cleanup {
catch {C destroy}
} -result {}
test ooUtil-2.1 {TIP 478: callback generation} -setup {
oo::class create parent
} -body {
oo::class create c {
superclass parent
method CallMe {} { return ok,[self] }
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
oo::class create parent
} -body {
::oo::class create A {
superclass parent
}
::oo::class create B {
superclass ::oo::class parent
| | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 |
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
}
|
| ︙ | ︙ | |||
562 563 564 565 566 567 568 |
}
} -cleanup {
namespace delete ooutiltest
rename animal {}
} -result {::ooutiltest::dog}
test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
oo::class create TestClass {
| | | | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
}
} -cleanup {
namespace delete ooutiltest
rename animal {}
} -result {::ooutiltest::dog}
test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
oo::class create TestClass {
superclass oo::class
self method create {name ignore body} {
next $name $body
}
}
} -body {
TestClass create okay {} {}
} -cleanup {
rename TestClass {}
} -result {::okay}
|
| ︙ | ︙ |
Changes to tests/package.test.
| ︙ | ︙ | |||
616 617 618 619 620 621 622 |
} -result {1.3}
test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
testpreferstable
package forget t
set x xxx
} -body {
foreach i {1.2b1 1.1} {
| | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
} -result {1.3}
test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
testpreferstable
package forget t
set x xxx
} -body {
foreach i {1.2b1 1.1} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
set x
} -result {1.1}
test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
package forget t
} -body {
|
| ︙ | ︙ |
Changes to tests/parse.test.
| ︙ | ︙ | |||
418 419 420 421 422 423 424 |
rename ::foo {}
rename ::unknown {}
rename unknown.save ::unknown
set ::info
} [subst {[set level 2; incr level [info level]] global 1 global 1 global}]
test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
set ::auto_index(noSuchCommand) {
| | | | | | | 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 |
rename ::foo {}
rename ::unknown {}
rename unknown.save ::unknown
set ::info
} [subst {[set level 2; incr level [info level]] global 1 global 1 global}]
test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
set ::auto_index(noSuchCommand) {
proc noSuchCommand {} {lappend ::info global}
}
set ::auto_index(::[string trimleft [namespace current]::test_ns_1::noSuchCommand :]) [list \
proc [namespace current]::test_ns_1::noSuchCommand {} {
lappend ::info ns
}]
catch {rename ::noSuchCommand {}}
set ::child [interp create]
$::child alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
$::child eval bar
}
namespace delete test_ns_1
interp delete $::child
catch {rename ::noSuchCommand {}}
set ::info
} global
|
| ︙ | ︙ |
Changes to tests/parseExpr.test.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
testexprparser "1 + 2" -1
} {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} testexprparser {
testexprparser 12345678901234567890 -1
} {- {} 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} \
-constraints testexprparser -body {
| | | | | | | | | | | | | | | | | | | 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 |
testexprparser "1 + 2" -1
} {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} testexprparser {
testexprparser 12345678901234567890 -1
} {- {} 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} \
-constraints testexprparser -body {
testexprparser {foo+} -1
} -match glob -returnCodes error -result *
test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} -constraints testexprparser -body {
testexprparser {1+2 345} -1
} -returnCodes error -match glob -result *
test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} testexprparser {
testexprparser {2>3? 1 : 0} -1
} {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} \
-constraints testexprparser -body {
testexprparser {0 || foo} -1
} -match glob -returnCodes error -result *
test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} testexprparser {
testexprparser {1+2} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} testexprparser {
testexprparser {1+2 ? 3 : 4} -1
} {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} testexprparser {
testexprparser {1+2 ? 12345678901234567890 : 0} -1
} {- {} 0 subexpr {1+2 ? 12345678901234567890 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 subexpr 0 1 text 0 0 {}}
test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} testexprparser {
testexprparser {1? 3 : 4} -1
} {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} \
-constraints testexprparser -body {
testexprparser {1? fred : martha} -1
} -match glob -returnCodes error -result *
test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} -constraints testexprparser -body {
testexprparser {1? 2 martha 3} -1
} -returnCodes error -match glob -result *
test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} testexprparser {
testexprparser {27||3? 3 : 4&&9} -1
} {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}}
test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} \
-constraints testexprparser -body {
testexprparser {1? 2 : martha} -1
} -match glob -returnCodes error -result *
test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} testexprparser {
testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} \
-constraints testexprparser -body {
testexprparser {1&&foo || 3} -1
} -match glob -returnCodes error -result *
test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} testexprparser {
testexprparser {1&&2? 1 : 0} -1
} {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} testexprparser {
testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} testexprparser {
testexprparser {1&&2 || 12345678901234567890} -1
} {- {} 0 subexpr {1&&2 || 12345678901234567890} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1&&2 || 3 || 4} -1
} {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1&&2 || 3 || martha} -1
} -match glob -returnCodes error -result *
test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} testexprparser {
testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} \
-constraints testexprparser -body {
testexprparser {1&&foo && 3} -1
} -match glob -returnCodes error -result *
test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} testexprparser {
testexprparser {1|2? 1 : 0} -1
} {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} testexprparser {
testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} testexprparser {
testexprparser {1|2 && 12345678901234567890} -1
} {- {} 0 subexpr {1|2 && 12345678901234567890} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1|2 && 3 && 4} -1
} {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1|2 && 3 && martha} -1
} -match glob -returnCodes error -result *
test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} testexprparser {
testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} \
-constraints testexprparser -body {
testexprparser {1|foo | 3} -1
} -match glob -returnCodes error -result *
test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} testexprparser {
testexprparser {1^2? 1 : 0} -1
} {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} testexprparser {
testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} testexprparser {
testexprparser {1^2 | 12345678901234567890} -1
} {- {} 0 subexpr {1^2 | 12345678901234567890} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1^2 | 3 | 4} -1
} {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1^2 | 3 | martha} -1
} -match glob -returnCodes error -result *
test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} testexprparser {
testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} \
-constraints testexprparser -body {
testexprparser {1^foo ^ 3} -1
} -match glob -returnCodes error -result *
test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} testexprparser {
testexprparser {1&2? 1 : 0} -1
} {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} testexprparser {
testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} testexprparser {
testexprparser {1&2 ^ 12345678901234567890} -1
} {- {} 0 subexpr {1&2 ^ 12345678901234567890} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1&2 ^ 3 ^ 4} -1
} {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1&2 ^ 3 ^ martha} -1
} -match glob -returnCodes error -result *
test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} testexprparser {
testexprparser {1==2 & 3} -1
} {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} \
-constraints testexprparser -body {
testexprparser {1!=foo & 3} -1
} -match glob -returnCodes error -result *
test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} testexprparser {
testexprparser {1==2? 1 : 0} -1
} {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} testexprparser {
testexprparser {1>2 & 3} -1
} {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {testexprparser} {
testexprparser {1==2 & 12345678901234567890} -1
} {- {} 0 subexpr {1==2 & 12345678901234567890} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1<2 & 3 & 4} -1
} {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1==2 & 3>2 & martha} -1
} -match glob -returnCodes error -result *
test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} testexprparser {
testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} \
-constraints testexprparser -body {
testexprparser {1>=foo == 3} -1
} -match glob -returnCodes error -result *
test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} testexprparser {
testexprparser {1<2? 1 : 0} -1
} {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser {
testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser {
testexprparser {1<2 != 3} -1
} {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} testexprparser {
testexprparser {1<2 == 12345678901234567890} -1
} {- {} 0 subexpr {1<2 == 12345678901234567890} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1<2 == 3 == 4} -1
} {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1<2 == 3 != martha} -1
} -match glob -returnCodes error -result *
test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} testexprparser {
testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} \
-constraints testexprparser -body {
testexprparser {1>=foo < 3} -1
} -match glob -returnCodes error -result *
test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} testexprparser {
testexprparser {1<<2? 1 : 0} -1
} {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
testexprparser {1<<2 < 12345678901234567890} -1
} {- {} 0 subexpr {1<<2 < 12345678901234567890} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1<<2 < 3 < 4} -1
} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
| | | | | | | | | 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 |
testexprparser {1<<2 < 12345678901234567890} -1
} {- {} 0 subexpr {1<<2 < 12345678901234567890} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1<<2 < 3 < 4} -1
} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1<<2 < 3 > martha} -1
} -match glob -returnCodes error -result *
test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} testexprparser {
testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} \
-constraints testexprparser -body {
testexprparser {1-foo << 3} -1
} -match glob -returnCodes error -result *
test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} testexprparser {
testexprparser {1+2? 1 : 0} -1
} {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser {
testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser {
testexprparser {1+2 >> 3} -1
} {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} testexprparser {
testexprparser {1+2 << 12345678901234567890} -1
} {- {} 0 subexpr {1+2 << 12345678901234567890} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1+2 << 3 << 4} -1
} {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1+2 << 3 >> martha} -1
} -match glob -returnCodes error -result *
test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \
-constraints testexprparser -body {
testexprparser {1/foo + 3} -1
} -match glob -returnCodes error -result *
test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser {
testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} testexprparser {
testexprparser {1*2 + 12345678901234567890} -1
} {- {} 0 subexpr {1*2 + 12345678901234567890} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1*2 + 3 - martha} -1
} -match glob -returnCodes error -result *
test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \
-constraints testexprparser -body {
testexprparser {1/foo + 3} -1
} -match glob -returnCodes error -result *
test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser {
testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} testexprparser {
testexprparser {1*2 + 12345678901234567890} -1
} {- {} 0 subexpr {1*2 + 12345678901234567890} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {1*2 + 3 - martha} -1
} -match glob -returnCodes error -result *
test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} testexprparser {
testexprparser {+2 * 3} -1
} {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} testexprparser {
testexprparser {-12345678901234567890 * 3} -1
|
| ︙ | ︙ | |||
418 419 420 421 422 423 424 |
testexprparser {--++5 / 12345678901234567890} -1
} {- {} 0 subexpr {--++5 / 12345678901234567890} 13 operator / 0 subexpr --++5 9 operator - 0 subexpr -++5 7 operator - 0 subexpr ++5 5 operator + 0 subexpr +5 3 operator + 0 subexpr 5 1 text 5 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {-2 / 3 % 4} -1
} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
| | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 |
testexprparser {--++5 / 12345678901234567890} -1
} {- {} 0 subexpr {--++5 / 12345678901234567890} 13 operator / 0 subexpr --++5 9 operator - 0 subexpr -++5 7 operator - 0 subexpr ++5 5 operator + 0 subexpr +5 3 operator + 0 subexpr 5 1 text 5 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} testexprparser {
testexprparser {-2 / 3 % 4} -1
} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} \
-constraints testexprparser -body {
testexprparser {++2 / 3 * martha} -1
} -match glob -returnCodes error -result *
test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
testexprparser {+2} -1
} {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
testexprparser {-2} -1
|
| ︙ | ︙ | |||
530 531 532 533 534 535 536 |
testexprparser {foo(123)} -1
} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}}
test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} -constraints testexprparser -body {
testexprparser {foo 12345678901234567890 123)} -1
} -returnCodes error -match glob -result *
test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} \
-constraints testexprparser -body {
| | | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 |
testexprparser {foo(123)} -1
} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}}
test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} -constraints testexprparser -body {
testexprparser {foo 12345678901234567890 123)} -1
} -returnCodes error -match glob -result *
test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} \
-constraints testexprparser -body {
testexprparser {foo 27.4 123)} -1
} -match glob -returnCodes error -result *
test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} testexprparser {
testexprparser {foo(12345678901234567890)} -1
} {- {} 0 subexpr foo(12345678901234567890) 3 operator foo 0 subexpr 12345678901234567890 1 text 12345678901234567890 0 {}}
test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} testexprparser {
testexprparser {foo(27*4)} -1
} {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}}
|
| ︙ | ︙ |
Changes to tests/parseOld.test.
|
| | < | | 1 2 3 4 5 6 7 8 9 | # Commands covered: set (plus basic command syntax). This set # of tests is an old one that predates the parser in Tcl 8.1. # # 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-1993 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. |
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
while executing
"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..."
("eval" body line 1)
invoked from within
"eval \$x[format "%01000d" 0]("}}
test parseOld-10.15 {syntax errors, missplaced braces} {
catch {
| | | | | | | | 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 |
while executing
"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..."
("eval" body line 1)
invoked from within
"eval \$x[format "%01000d" 0]("}}
test parseOld-10.15 {syntax errors, missplaced braces} {
catch {
proc misplaced_end_brace {} {
set what foo
set when [expr ${what}size - [set off$what]}]
} msg
set msg
} {extra characters after close-brace}
test parseOld-10.16 {syntax errors, missplaced braces} {
catch {
set a {
set what foo
set when [expr ${what}size - [set off$what]}]
} msg
set msg
} {extra characters after close-brace}
test parseOld-10.17 {syntax errors, unusual spacing} {
list [catch {return [ [1]]} msg] $msg
} {1 {invalid command name "1"}}
# Long values (stressing storage management)
|
| ︙ | ︙ |
Changes to tests/pid.test.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
close $f
set pids
} -cleanup {
removeFile test1
} -result {}
test pid-1.4 {pid command} pidDefined {
list [catch {pid a b} msg] $msg
| | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
close $f
set pids
} -cleanup {
removeFile test1
} -result {}
test pid-1.4 {pid command} pidDefined {
list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channel?"}}
test pid-1.5 {pid command} pidDefined {
list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/proc-old.test.
| ︙ | ︙ | |||
478 479 480 481 482 483 484 |
"tproc2"} none}
test proc-old-7.15 {return with special completion code} {
list [catch {return -badOption foo message} msg] $msg
} {2 message}
test proc-old-8.1 {unset and undefined local arrays} {
proc t1 {} {
| | | | | | | | | | | | 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 |
"tproc2"} none}
test proc-old-7.15 {return with special completion code} {
list [catch {return -badOption foo message} msg] $msg
} {2 message}
test proc-old-8.1 {unset and undefined local arrays} {
proc t1 {} {
foreach v {xxx, yyy} {
catch {unset $v}
}
set yyy(foo) bar
}
t1
} bar
test proc-old-9.1 {empty command name} {
catch {rename {} ""}
proc t1 {args} {
return
}
set v [t1]
catch {$v}
} 1
test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
proc t1 x {
set y 20
rename expr expr.old
rename expr.old expr
if {$x} then {t1 0} ;# recursive call after foo's code is invalidated
return 20
}
t1 1
} 20
# cleanup
catch {rename t1 ""}
catch {rename foo ""}
|
| ︙ | ︙ |
Changes to tests/proc.test.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 |
catch {rename {} ""}
catch {unset msg}
test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
catch {rename {} ""}
catch {unset msg}
test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
namespace eval baz {}
}
proc test_ns_1::baz::p {} {
return "p in [namespace current]"
}
list [test_ns_1::baz::p] \
[namespace eval test_ns_1 {baz::p}] \
[info commands test_ns_1::baz::*]
} -result {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -returnCodes error -body {
proc test_ns_1::baz::p {} {}
} -result {can't create procedure "test_ns_1::baz::p": unknown namespace}
test proc-1.3 {Tcl_ProcObjCmd, empty proc name} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
proc :: {} {
return "empty called"
}
list [::] \
[info body {}]
} -result {{empty called} {
return "empty called"
}}
test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {
return "p in [namespace current]"
}
}
}
list [test_ns_1::baz::p] \
[info commands test_ns_1::baz::*]
} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {
return "p in [namespace current]"
}
}
list [test_ns_1::baz::p] \
[info commands test_ns_1::baz::*] \
[namespace eval test_ns_1::baz {namespace which p}]
} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
proc q: {} {return "q:"}
proc value:at: {} {return "value:at:"}
}
list [namespace eval test_ns_1 {q:}] \
[namespace eval test_ns_1 {value:at:}] \
[test_ns_1::q:] \
[test_ns_1::value:at:] \
[lsort [info commands test_ns_1::*]] \
[namespace eval test_ns_1 {namespace which q:}] \
[namespace eval test_ns_1 {namespace which value:at:}]
} -result {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup {
catch {rename p ""}
} -returnCodes error -body {
proc p {a(1) a(2)} {
set z [expr {$a(1)+$a(2)}]
puts "$z=z, $a(1)=$a(1)"
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
proc p {} {return "p in [namespace current]"}
info body p
} -result {return "p in [namespace current]"}
test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
| | | | | | 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 |
proc p {} {return "p in [namespace current]"}
info body p
} -result {return "p in [namespace current]"}
test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {return "p in [namespace current]"}
}
}
namespace eval test_ns_1::baz {info body p}
} -result {return "p in [namespace current]"}
test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {return "p in [namespace current]"}
}
namespace eval test_ns_1 {info body baz::p}
} -result {return "p in [namespace current]"}
test proc-2.4 {TclFindProc, global proc and executing in namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
} -body {
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
proc p {} {return "p in [namespace current]"}
p
} -result {p in ::}
test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1::baz {
| | | | | | | | 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 |
proc p {} {return "p in [namespace current]"}
p
} -result {p in ::}
test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
p
}
} -result {p in ::test_ns_1::baz}
test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
} -body {
proc p {} {return "p in [namespace current]"}
namespace eval test_ns_1::baz {
p
}
} -result {p in ::}
test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
} -body {
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
rename ::test_ns_1::baz::p ::p
list [p] [namespace which p]
}
} -result {{p in ::} ::p}
test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} -body {
proc p {x} {info commands 3m}
p
} -returnCodes error -result {wrong # args: should be "p x"}
test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} -body {
|
| ︙ | ︙ |
Changes to tests/process.test.
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
test process-4.1 {exec one child} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(exit) 0 &]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status [lindex [tcl::process status $pid] 1]
expr {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test process-4.1 {exec one child} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(exit) 0 &]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status [lindex [tcl::process status $pid] 1]
expr {
[llength $list] eq 1
&& [lindex $list 0] eq $pid
&& [dict size $statuses] eq 1
&& [dict get $statuses $pid] eq $status
&& $status eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# - Two children
test process-4.2 {exec two children in parallel} -body {
tcl::process autopurge 0
set pid1 [exec [interpreter] $path(exit) 0 &]
set pid2 [exec [interpreter] $path(exit) 0 &]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
expr {
[llength $list] eq 2
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [dict size $statuses] eq 2
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& $status1 eq 0
&& $status2 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# - 3-stage pipe
test process-4.3 {exec 3-stage pipe} -body {
tcl::process autopurge 0
set pids [exec \
[interpreter] $path(exit) 0 \
| [interpreter] $path(exit) 0 \
| [interpreter] $path(exit) 0 \
&]
lassign $pids pid1 pid2 pid3
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
set status3 [lindex [tcl::process status $pid3] 1]
expr {
[llength $pids] eq 3
&& [llength $list] eq 3
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [lsearch $list $pid3] >= 0
&& [dict size $statuses] eq 3
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& [dict get $statuses $pid3] eq $status3
&& $status1 eq 0
&& $status2 eq 0
&& $status3 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# Spawn subprocesses using [open "|"]
# - One child
test process-5.1 {exec one child} -body {
tcl::process autopurge 0
set f [open "|\"[interpreter]\" \"$path(exit)\" 0"]
set pid [pid $f]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status [lindex [tcl::process status $pid] 1]
expr {
[llength $list] eq 1
&& [lindex $list 0] eq $pid
&& [dict size $statuses] eq 1
&& [dict get $statuses $pid] eq $status
&& $status eq 0
}
} -result {1} -cleanup {
close $f
tcl::process purge
tcl::process autopurge 1
}
# - Two children
test process-5.2 {exec two children in parallel} -body {
tcl::process autopurge 0
set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
set pid1 [pid $f1]
set pid2 [pid $f2]
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
expr {
[llength $list] eq 2
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [dict size $statuses] eq 2
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& $status1 eq 0
&& $status2 eq 0
}
} -result {1} -cleanup {
close $f1
close $f2
tcl::process purge
tcl::process autopurge 1
}
# - 3-stage pipe
test process-5.3 {exec 3-stage pipe} -body {
tcl::process autopurge 0
set f [open "|
\"[interpreter]\" \"$path(exit)\" 0
| \"[interpreter]\" \"$path(exit)\" 0
| \"[interpreter]\" \"$path(exit)\" 0
"]
set pids [pid $f]
lassign $pids pid1 pid2 pid3
set list [tcl::process list]
set statuses [tcl::process status -wait]
set status1 [lindex [tcl::process status $pid1] 1]
set status2 [lindex [tcl::process status $pid2] 1]
set status3 [lindex [tcl::process status $pid3] 1]
expr {
[llength $pids] eq 3
&& [llength $list] eq 3
&& [lsearch $list $pid1] >= 0
&& [lsearch $list $pid2] >= 0
&& [lsearch $list $pid3] >= 0
&& [dict size $statuses] eq 3
&& [dict get $statuses $pid1] eq $status1
&& [dict get $statuses $pid2] eq $status2
&& [dict get $statuses $pid3] eq $status3
&& $status1 eq 0
&& $status2 eq 0
&& $status3 eq 0
}
} -result {1} -cleanup {
close $f
tcl::process purge
tcl::process autopurge 1
}
# Async child status
test process-6.1 {async status} -setup {
signal_exit $path(test-signalfile) 0; # clean signal-file
} -body {
tcl::process autopurge 0
set pid [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &]
set status1 [lindex [tcl::process status $pid] 1]
signal_exit $path(test-signalfile); # signal exit (stop sleep)
set status2 [lindex [tcl::process status -wait $pid] 1]
expr {
$status1 eq {}
&& $status2 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
test process-6.2 {selective wait} -setup {
signal_exit $path(test-signalfile) 0; # clean signal-files
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 |
set status2_1 [lindex [tcl::process status -wait $pid1] 1]
set status2_2 [lindex [tcl::process status $pid2] 1]
# Wait until child 2 termination
signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep)
set status3_2 [lindex [tcl::process status -wait $pid2] 1]
set status3_1 [lindex [tcl::process status $pid1] 1]
expr {
| | | | | | | | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
set status2_1 [lindex [tcl::process status -wait $pid1] 1]
set status2_2 [lindex [tcl::process status $pid2] 1]
# Wait until child 2 termination
signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep)
set status3_2 [lindex [tcl::process status -wait $pid2] 1]
set status3_1 [lindex [tcl::process status $pid1] 1]
expr {
$status1_1 eq {}
&& $status1_2 eq {}
&& $status2_1 eq 0
&& $status2_2 eq {}
&& $status3_1 eq 0
&& $status3_2 eq 0
}
} -result {1} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
# Error codes
|
| ︙ | ︙ |
Changes to tests/reg.test.
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
######## the tests themselves ########
# support functions and preliminary misc.
# This is sensitive to changes in message wording, but we really have to
# test the code->message expansion at least once.
::tcltest::test reg-0.1 "regexp error reporting" {
list [catch {regexp (*) ign} msg] $msg
| | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
######## the tests themselves ########
# support functions and preliminary misc.
# This is sensitive to changes in message wording, but we really have to
# test the code->message expansion at least once.
::tcltest::test reg-0.1 "regexp error reporting" {
list [catch {regexp (*) ign} msg] $msg
} {1 {cannot compile regular expression pattern: invalid quantifier operand}}
doing 1 "basic sanity checks"
expectMatch 1.1 & abc abc abc
expectNomatch 1.2 & abc def
expectMatch 1.3 & abc xyabxabce abc
|
| ︙ | ︙ |
Changes to tests/regexp.test.
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
list [catch {regexp -nocase a} msg] $msg
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
list [catch {regexp -gorp a} msg] $msg
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
list [catch {regexp a( b} msg] $msg
| | | | | 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 |
list [catch {regexp -nocase a} msg] $msg
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
list [catch {regexp -gorp a} msg] $msg
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
list [catch {regexp a( b} msg] $msg
} {1 {cannot compile regular expression pattern: parentheses () not balanced}}
test regexp-6.5 {regexp errors} {
list [catch {regexp a( b} msg] $msg
} {1 {cannot compile regular expression pattern: parentheses () not balanced}}
test regexp-6.6 {regexp errors} {
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
} {0 1}
test regexp-6.7 {regexp errors} {
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
} {0 0}
test regexp-6.8 {regexp errors} -setup {
unset -nocomplain f1
} -body {
set f1 44
regexp abc abc f1(f2)
} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
test regexp-6.9 {regexp errors, -start bad int check} {
list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexp-6.10 {regexp errors} {
list [catch {regexp {a[} b} msg] $msg
} {1 {cannot compile regular expression pattern: brackets [] not balanced}}
test regexp-7.1 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
} {1 xax111aaa222xaa}
test regexp-7.2 {basic regsub operation} {
list [regsub aa+ aaaxaa &111 foo] $foo
} {1 aaa111xaa}
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
list [catch {regsub a b c d e f} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-11.6 {regsub errors} {
list [catch {regsub -nocase a( b c d} msg] $msg
| | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
list [catch {regsub a b c d e f} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-11.6 {regsub errors} {
list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {cannot compile regular expression pattern: parentheses () not balanced}}
test regexp-11.7 {regsub errors} -setup {
unset -nocomplain f1
} -body {
set f1 44
regsub -nocase aaa aaa xxx f1(f2)
} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
test regexp-11.8 {regsub errors, -start bad int check} {
|
| ︙ | ︙ | |||
885 886 887 888 889 890 891 |
[a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
[a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a
} -cleanup {
rename a {}
| | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
[a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
[a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a
} -cleanup {
rename a {}
} -returnCodes 1 -match glob -result {cannot compile regular expression pattern: *}
test regexp-22.5 {Bug 3610026} -setup {
set e {}
set cp 99
while {$cp < 32864} {
append e [format %c [incr cp]]
}
} -body {
|
| ︙ | ︙ |
Changes to tests/regexpComp.test.
| ︙ | ︙ | |||
327 328 329 330 331 332 333 |
list [catch {regexp -gorp a} msg] $msg
}
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
| | | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
list [catch {regexp -gorp a} msg] $msg
}
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {cannot compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.5 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {cannot compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.6 {regexp errors} {
evalInProc {
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
}
} {0 1}
test regexpComp-6.7 {regexp errors} {
evalInProc {
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
list [catch {regsub -gorp a b c} msg] $msg
}
} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
}
| | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
list [catch {regsub -gorp a b c} msg] $msg
}
} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
}
} {1 {cannot compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
evalInProc {
unset -nocomplain f1
set f1 44
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
}
} {1 {can't set "f1(f2)": variable isn't array}}
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
}
} 0
test regexpComp-24.9 {regexp command compiling tests} {
evalInProc {
set re "("
list [catch {regexp -- $re dogfod} msg] $msg
}
| | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
}
} 0
test regexpComp-24.9 {regexp command compiling tests} {
evalInProc {
set re "("
list [catch {regexp -- $re dogfod} msg] $msg
}
} {1 {cannot compile regular expression pattern: parentheses () not balanced}}
test regexpComp-24.10 {regexp command compiling tests} {
# Bug 1902436 - last * escaped
evalInProc {
set text {this is *bold* !}
set re {\*bold\*}
regexp -- $re $text
}
|
| ︙ | ︙ |
Changes to tests/registry.test.
| ︙ | ︙ | |||
570 571 572 573 574 575 576 |
lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]
} -cleanup {
registry delete HKEY_CURRENT_USER\\TclFoobar
} -result {{baz bar} blat}
test registry-8.1 {OpenSubKey} -constraints {win reg nonPortable english} \
-body {
| | | | | 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]
} -cleanup {
registry delete HKEY_CURRENT_USER\\TclFoobar
} -result {{baz bar} blat}
test registry-8.1 {OpenSubKey} -constraints {win reg nonPortable english} \
-body {
# This test will only succeed if the current user does not have
# registry access on the specified machine.
registry keys {\\mom\HKEY_LOCAL_MACHINE}
} -returnCodes error -result "unable to open key: Access is denied."
test registry-8.2 {OpenSubKey} -constraints {win reg} -setup {
registry delete HKEY_CURRENT_USER\\TclFoobar
registry set HKEY_CURRENT_USER\\TclFoobar
} -body {
registry keys HKEY_CURRENT_USER TclFoobar
} -cleanup {
|
| ︙ | ︙ | |||
640 641 642 643 644 645 646 |
registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4
} -cleanup {
registry delete HKEY_CURRENT_USER\\TclFoobar
} -result {}
test registry-11.1 {SetValue: recursive creation} \
-constraints {win reg} -setup {
| | | | | | | | | | | | 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 |
registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4
} -cleanup {
registry delete HKEY_CURRENT_USER\\TclFoobar
} -result {}
test registry-11.1 {SetValue: recursive creation} \
-constraints {win reg} -setup {
registry delete HKEY_CURRENT_USER\\TclFoobar
} -body {
registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
} -result {foobar}
test registry-11.2 {SetValue: modification} -constraints {win reg} \
-setup {
registry delete HKEY_CURRENT_USER\\TclFoobar
} -body {
registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob
set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
} -result {frob}
test registry-11.3 {SetValue: failure} \
-constraints {win reg nonPortable english} \
-body {
# This test will only succeed if the current user does not have
# registry access on the specified machine.
registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar
} -returnCodes error -result {unable to open key: Access is denied.}
test registry-12.1 {BroadcastValue} -constraints {win reg} -body {
registry broadcast
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.2 {BroadcastValue} -constraints {win reg} -body {
registry broadcast "" -time
|
| ︙ | ︙ |
Changes to tests/remote.tcl.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
}
proc __readAndExecute__ {s} {
global command VERBOSE
set l [gets $s]
if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
| | | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
}
proc __readAndExecute__ {s} {
global command VERBOSE
set l [gets $s]
if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
puts $s [__doCommands__ $command($s) $s]
puts $s "--Marker--Marker--Marker--"
set command($s) ""
return
}
if {[string compare $l ""] == 0} {
if {[eof $s]} {
if {$VERBOSE} {
puts "Server closing $s, eof from client"
}
close $s
}
return
}
if {[eof $s]} {
if {$VERBOSE} {
puts "Server closing $s, eof from client"
}
close $s
unset command($s)
return
}
append command($s) $l "\n"
}
proc __accept__ {s a p} {
global command VERBOSE
|
| ︙ | ︙ |
Changes to tests/rename.test.
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
catch {rename unknown unknown.old}
set SAVED_UNKNOWN "proc unknown "
append SAVED_UNKNOWN [list [info args unknown.old] [info body unknown.old]]
test rename-5.1 {repeated rename deletion and redefinition of same command} {
for {set i 0} {$i < 10} {incr i} {
| | | | | | | | 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 |
catch {rename unknown unknown.old}
set SAVED_UNKNOWN "proc unknown "
append SAVED_UNKNOWN [list [info args unknown.old] [info body unknown.old]]
test rename-5.1 {repeated rename deletion and redefinition of same command} {
for {set i 0} {$i < 10} {incr i} {
eval $SAVED_UNKNOWN
tcl_wordBreakBefore "" 0
rename tcl_wordBreakBefore {}
rename unknown {}
}
} {}
catch {rename unknown {}}
catch {rename unknown.old unknown}
test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed} -body {
proc x {} {
set a 123
set b [incr a]
}
x
rename incr incr.old
proc incr {} {puts "new incr called!"}
x
} -cleanup {
rename incr {}
|
| ︙ | ︙ |
Changes to tests/result.test.
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
proc foo {} {catch {return -level 2}; testreturn}
foo
} -cleanup {
rename foo {}
} -result {}
test result-6.2 {Bug 1649062} -setup {
proc foo {} {
| | | | | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
proc foo {} {catch {return -level 2}; testreturn}
foo
} -cleanup {
rename foo {}
} -result {}
test result-6.2 {Bug 1649062} -setup {
proc foo {} {
if {[catch {
return -code error -errorinfo custom -errorcode CUSTOM foo
} err]} {
return [list $err $::errorCode $::errorInfo]
}
}
set ::errorInfo {}
set ::errorCode {}
} -body {
foo
} -cleanup {
rename foo {}
|
| ︙ | ︙ |
Changes to tests/safe-stock.test.
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
lappend PathMapp [file join [info library] $pkgOptDir] TCLLIB/OPTDIR
lappend PathMapp [file join [info library] $pkgJarDir] TCLLIB/JARDIR
lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR
proc mapList {map listIn} {
set listOut {}
foreach element $listIn {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
lappend PathMapp [file join [info library] $pkgOptDir] TCLLIB/OPTDIR
lappend PathMapp [file join [info library] $pkgJarDir] TCLLIB/JARDIR
lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR
proc mapList {map listIn} {
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
return $listOut
}
proc mapAndSortList {map listIn} {
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
lsort $listOut
}
# Force actual loading of the safe package because we use unexported (and
# thus unautoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
testConstraint AutoSyncDefined 1
# high level general test
test safe-stock-7.1 {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set i [safe::interpCreate]
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require opt}]
# no error shall occur:
interp eval $i {::tcl::Lempty {a list}}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 0.4.*
test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# an error shall occur (opt is not anymore in the secure 0-level
# provided deep path)
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
list $token1 $token2 -- \
[catch {interp eval $i {package require opt}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\
{TCLLIB */dummy/unixlike/test/path} -- {}"
test safe-stock-7.4 {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# this time, unlike test safe-stock-7.2, opt should be found
list $token1 $token2 -- \
[catch {interp eval $i {package require opt}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
# Note that the glob match elides directories (those from the module path)
# other than the first and last in the access path.
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\
{TCLLIB * TCLLIB/OPTDIR} -- {}}
test safe-stock-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set i [safe::interpCreate]
interp eval $i {
package forget platform::shell
package forget platform
catch {namespace delete ::platform}
}
} -body {
# Should raise an error (module ancestor directory issue)
set code1 [catch {interp eval $i {package require shell}} msg1]
# Should not raise an error
set code2 [catch {interp eval $i {package require platform::shell}} msg2]
return [list $code1 $msg1 $code2]
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package shell} 0}
# The following test checks whether the definition of tcl_endOfWord can be
# obtained from auto_loading. It was previously test "safe-5.1".
test safe-stock-9.8 {test auto-loading in safe interpreters, was safe-5.1} -setup {
catch {safe::interpDelete a}
safe::interpCreate a
} -body {
interp eval a {tcl_endOfWord "" 0}
} -cleanup {
safe::interpDelete a
} -result -1
test safe-stock-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $tcl_library $pkgOptDir] \
[file join $tcl_library $pkgJarDir]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]]
set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
# This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $tcl_library $pkgJarDir] \
[file join $tcl_library $pkgOptDir]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]]
set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require tcl::idna}} msg3]
set code4 [catch {interp eval $i {package require opt}} msg4]
set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5]
set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} msg6]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.* 0 0.4.* --\
{TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\
{TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\
0 0 0 example.com}
test safe-stock-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $tcl_library $pkgOptDir] \
[file join $tcl_library $pkgJarDir]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]]
set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]]
# Load pkgIndex.tcl data.
|
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5]
# Try to load the packages.
set code3 [catch {interp eval $i {package require opt}} msg3]
set code6 [catch {interp eval $i {package require tcl::idna}} msg6]
list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
| | | | | | | | | 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 |
set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5]
# Try to load the packages.
set code3 [catch {interp eval $i {package require opt}} msg3]
set code6 [catch {interp eval $i {package require tcl::idna}} msg6]
list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
$mappA -- $mappB
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\
1 {* not found in access path} -- 1 1 --\
{TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}}
test safe-stock-18.1 {cf. safe-stock-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
# because the child will use the same value.
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
|
| ︙ | ︙ | |||
329 330 331 332 333 334 335 |
set v [interp eval $i {package require opt}]
# no error shall occur:
interp eval $i {::tcl::Lempty {a list}}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
| | | | | | | | | | | | 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 |
set v [interp eval $i {package require opt}]
# no error shall occur:
interp eval $i {::tcl::Lempty {a list}}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 0.4.*
test safe-stock-18.2 {cf. safe-stock-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
set auto1 [interp eval $i {set ::auto_path}]
# This will differ from the value -autoPath {}
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# an error shall occur (opt is not anymore in the secure 0-level
# provided deep path)
list $auto1 $token1 $token2 \
[catch {interp eval $i {package require opt}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\
{-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\
-statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
test safe-stock-18.4 {cf. safe-stock-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not have been set by Safe Base:
set auto1 [interp eval $i {set ::auto_path}]
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\
| | | | | | | | | | | 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 |
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\
{-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\
-statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
test safe-stock-18.5 {cf. safe-stock-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate]
interp eval $i {
package forget platform::shell
package forget platform
catch {namespace delete ::platform}
}
} -body {
# Should raise an error (tests module ancestor directory rule)
set code1 [catch {interp eval $i {package require shell}} msg1]
# Should not raise an error
set code2 [catch {interp eval $i {package require platform::shell}} msg2]
return [list $code1 $msg1 $code2]
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package shell} 0}
set ::auto_path $SaveAutoPath
unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp
rename mapList {}
rename mapAndSortList {}
|
| ︙ | ︙ |
Changes to tests/safe-zipfs.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
apply [list {} {
global auto_path
global tcl_library
if {"::tcltest" ni [namespace children]} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
apply [list {} {
global auto_path
global tcl_library
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
foreach i [interp children] {
interp delete $i
}
set SaveAutoPath $::auto_path
set ::auto_path [info library]
set TestsDir [file normalize [file dirname [info script]]]
set ZipMountPoint [zipfs root]auto-files
zipfs mount [file join $TestsDir auto-files.zip] $ZipMountPoint
set PathMapp {}
lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR $ZipMountPoint ZIPDIR
proc mapList {map listIn} {
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
return $listOut
}
proc mapAndSortList {map listIn} {
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
lsort $listOut
}
# Force actual loading of the safe package because we use un-exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
testConstraint AutoSyncDefined 1
# Tests 5.* test the example files before using them to test safe interpreters.
test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]
} -body {
# Try to load the commands.
set code3 [catch report1 msg3]
set code4 [catch report2 msg4]
list $code3 $msg3 $code4 $msg4
} -cleanup {
catch {rename report1 {}}
catch {rename report2 {}}
set ::auto_path $tmpAutoPath
auto_reset
} -match glob -result {0 ok1 0 ok2}
test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0]
} -body {
# Try to load the commands.
set code3 [catch report1 msg3]
set code4 [catch report2 msg4]
list $code3 $msg3 $code4 $msg4
} -cleanup {
catch {rename report1 {}}
catch {rename report2 {}}
set ::auto_path $tmpAutoPath
auto_reset
} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}}
test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0]
} -body {
# Try to load the packages and run a command from each one.
set code3 [catch {package require SafeTestPackage1} msg3]
set code4 [catch {package require SafeTestPackage2} msg4]
set code5 [catch HeresPackage1 msg5]
set code6 [catch HeresPackage2 msg6]
list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
} -cleanup {
set ::auto_path $tmpAutoPath
catch {package forget SafeTestPackage1}
catch {package forget SafeTestPackage2}
catch {rename HeresPackage1 {}}
catch {rename HeresPackage2 {}}
} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]
} -body {
# Try to load the packages and run a command from each one.
set code3 [catch {package require SafeTestPackage1} msg3]
set code4 [catch {package require SafeTestPackage2} msg4]
set code5 [catch HeresPackage1 msg5]
set code6 [catch HeresPackage2 msg6]
list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
} -cleanup {
set ::auto_path $tmpAutoPath
catch {package forget SafeTestPackage1}
catch {package forget SafeTestPackage2}
catch {rename HeresPackage1 {}}
catch {rename HeresPackage2 {}}
} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup {
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
# Try to load the modules and run a command from each one.
set code0 [catch {package require test0} msg0]
set code1 [catch {package require mod1::test1} msg1]
set code2 [catch {package require mod2::test2} msg2]
set out0 [test0::try0]
set out1 [mod1::test1::try1]
set out2 [mod2::test2::try2]
list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
catch {package forget test0}
catch {package forget mod1::test1}
catch {package forget mod2::test2}
catch {namespace delete ::test0}
catch {namespace delete ::mod1}
} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
test safe-zipfs-5.6 {example modules packages, test in parent interpreter, append to path; zipfs} -setup {
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
# Try to load the modules and run a command from each one.
set code0 [catch {package require test0} msg0]
set code1 [catch {package require mod1::test1} msg1]
set code2 [catch {package require mod2::test2} msg2]
set out0 [test0::try0]
set out1 [mod1::test1::try1]
set out2 [mod2::test2::try2]
list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
catch {package forget test0}
catch {package forget mod1::test1}
catch {package forget mod2::test2}
catch {namespace delete ::test0}
catch {namespace delete ::mod1}
} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
# high level general test
# Use zipped example packages not http1.0 etc
test safe-zipfs-7.1 {tests that everything works at high level with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0]
set i [safe::interpCreate]
set ::auto_path $tmpAutoPath
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i {HeresPackage1}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 1.2.3
test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
# provided deep path)
list $token1 $token2 $token3 -- [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- $mappA -- [safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} -- 1 {can't find package SafeTestPackage1} -- {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}}
test safe-zipfs-7.4 {tests specific path and positive search with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found
list $token1 $token2 -- [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- $mappA -- [safe::interpDelete $i]
# Note that the glob match elides directories (those from the module path)
# other than the first and last in the access path.
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 -- {TCLLIB * ZIPDIR/auto0/auto1} -- {}}
test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset) with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Load auto_load data.
interp eval $i {catch nonExistentCommand}
# Load and run the commands.
# This guarantees the test will pass even if the tokens are swapped.
set code1 [catch {interp eval $i {report1}} msg1]
set code2 [catch {interp eval $i {report2}} msg2]
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Run the commands.
set code3 [catch {interp eval $i {report1}} msg3]
set code4 [catch {interp eval $i {report2}} msg4]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}}
test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset) with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Load auto_load data.
interp eval $i {catch nonExistentCommand}
# Do not load the commands. With the tokens swapped, the test
# will pass only if the Safe Base has called auto_reset.
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Load and run the commands.
set code3 [catch {interp eval $i {report1}} msg3]
set code4 [catch {interp eval $i {report2}} msg4]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}}
test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
# For complete correspondence to safe-stock-9.11, include auto0 in access path.
set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0] [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
# This would have no effect because the records in Pkg of these directories
# were from access as children of {$p(:1:)}.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0] [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 -- {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} -- 0 OK1 0 OK2}
test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0 with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.2.3 0 2.3.4 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} -- 0 OK1 0 OK2}
test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4]
set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5]
# Try to load the packages.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- $mappA -- $mappB
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} -- 1 {* not found in access path} -- 1 1 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}}
test safe-zipfs-9.20 {check module loading, with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in
# tokenized form to the child's access path, and then adds all the
# descendants, discovered recursively by using glob.
# - The order of the directories in the list returned by glob is system-dependent,
# and therefore this is true also for (a) the order of token assignment to
# descendants of the [tcl::tm::list] roots; and (b) the order of those same
# directories in the access path. Both those things must be sorted before
# comparing with expected results. The test is therefore not totally strict,
# but will notice missing or surplus directories.
test safe-zipfs-9.21 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 1; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Load pkg data.
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
# See comments on lsort after test safe-zipfs-9.20.
test safe-zipfs-9.22 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 0; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
# See comments on lsort after test safe-zipfs-9.20.
test safe-zipfs-9.23 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 3; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Force the interpreter to acquire pkg data which will soon become stale.
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Refresh stale pkg data.
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
# See comments on lsort after test safe-zipfs-9.20.
test safe-zipfs-9.24 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 2 (worst case); zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Force the interpreter to acquire pkg data which will soon become stale.
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
# See comments on lsort after test safe-zipfs-9.20.
test safe-zipfs-18.1 {cf. safe-zipfs-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
# because the child will use the same value.
set lib1 [info library]
set lib2 [file join $ZipMountPoint auto0]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
set i [safe::interpCreate]
set ::auto_path $::auto_TMP
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i HeresPackage1
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 1.2.3
test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
set auto1 [interp eval $i {set ::auto_path}]
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
# an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
# provided deep path)
list $auto1 $token1 $token2 $token3 [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg [safe::interpConfigure $i] [safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1 {can't find package SafeTestPackage1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path $ZipMountPoint/auto0]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
test safe-zipfs-18.4 {cf. safe-zipfs-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not have been set by Safe Base:
set auto1 [interp eval $i {set ::auto_path}]
# This will differ from the value -autoPath {}
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]]
# should not have been changed by Safe Base:
set auto2 [interp eval $i {set ::auto_path}]
# This will differ from the value -autoPath {}
set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]]
# This time, unlike test safe-zipfs-18.2 and the try above, SafeTestPackage1 should be found:
list $auto1 $auto2 $token1 $token2 $token3 [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg [safe::interpConfigure $i] [safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3 {-accessPath {[list $tcl_library *$ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
# cleanup
set ::auto_path $SaveAutoPath
zipfs unmount ${ZipMountPoint}
unset SaveAutoPath TestsDir ZipMountPoint PathMapp
rename mapList {}
|
| ︙ | ︙ |
Changes to tests/safe.test.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
set ap1 [lrange [lindex [safe::interpConfigure $child -autoPath] 1] 0 end]
set ap2 [::safe::DetokPath $child [interp eval $child set ::auto_path]]
list $ap1 -- $ap2
}
proc mapList {map listIn} {
set listOut {}
foreach element $listIn {
| | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
set ap1 [lrange [lindex [safe::interpConfigure $child -autoPath] 1] 0 end]
set ap2 [::safe::DetokPath $child [interp eval $child set ::auto_path]]
list $ap1 -- $ap2
}
proc mapList {map listIn} {
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
return $listOut
}
proc mapAndSortList {map listIn} {
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
lsort $listOut
}
# Force actual loading of the safe package because we use unexported (and
# thus unautoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
|
| ︙ | ︙ | |||
71 72 73 74 75 76 77 |
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
safe::interpConfigure
} -result {no value given for parameter "child" (use -help for full usage) :
child name () name of the child}
test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
| | | | | | | | | | 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 |
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
safe::interpConfigure
} -result {no value given for parameter "child" (use -help for full usage) :
child name () name of the child}
test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
safe::interpCreate -help
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
(-help gives this help)
?child? name () name of the child (optional)
-accessPath list () access path for the child
-noStatics boolflag (false) prevent loading of statically linked pkgs
-statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
-nested boolean (false) nested loading
-deleteHook script () delete hook}
test safe-1.2.1 {safe::interpCreate syntax, Sync Mode off} -returnCodes error -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
safe::interpCreate -help
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
(-help gives this help)
?child? name () name of the child (optional)
-accessPath list () access path for the child
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
catch {package forget SafeTestPackage2}
catch {rename HeresPackage1 {}}
catch {rename HeresPackage2 {}}
} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
test safe-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir auto0 auto1] \
| | | | | 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 |
catch {package forget SafeTestPackage2}
catch {rename HeresPackage1 {}}
catch {rename HeresPackage2 {}}
} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
test safe-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]
} -body {
# Try to load the packages and run a command from each one.
set code3 [catch {package require SafeTestPackage1} msg3]
set code4 [catch {package require SafeTestPackage2} msg4]
set code5 [catch HeresPackage1 msg5]
set code6 [catch HeresPackage2 msg6]
list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
} -cleanup {
set ::auto_path $tmpAutoPath
catch {package forget SafeTestPackage1}
catch {package forget SafeTestPackage2}
catch {rename HeresPackage1 {}}
catch {rename HeresPackage2 {}}
} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
test safe-5.5 {example modules packages, test in parent interpreter, replace path} -setup {
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
# Try to load the modules and run a command from each one.
set code0 [catch {package require test0} msg0]
set code1 [catch {package require mod1::test1} msg1]
set code2 [catch {package require mod2::test2} msg2]
set out0 [test0::try0]
set out1 [mod1::test1::try1]
set out2 [mod2::test2::try2]
list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
catch {package forget test0}
catch {package forget mod1::test1}
catch {package forget mod2::test2}
catch {namespace delete ::test0}
catch {namespace delete ::mod1}
} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
### 7. Test the use of ::auto_path for loading commands (via tclIndex files)
### and non-module packages (via pkgIndex.tcl files).
### Corresponding tests with Sync Mode off are 17.*
test safe-7.1 {positive non-module package require, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
### 7. Test the use of ::auto_path for loading commands (via tclIndex files)
### and non-module packages (via pkgIndex.tcl files).
### Corresponding tests with Sync Mode off are 17.*
test safe-7.1 {positive non-module package require, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir auto0]
set i [safe::interpCreate]
set ::auto_path $tmpAutoPath
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i {HeresPackage1}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 1.2.3
test safe-7.2 {negative non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory)
list $token1 $token2 $token3 -- \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\
1 {can't find package SafeTestPackage1} --\
{TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}}
test safe-7.3 {check that safe subinterpreters work} {
set g [interp children]
if {$g ne {}} {
append g { -- residue of an earlier test}
}
set h [info vars ::safe::S*]
if {$h ne {}} {
append h { -- residue of an earlier test}
}
set i [safe::interpCreate]
set j [safe::interpCreate [list $i x]]
list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \
[interp exists $j] [info vars ::safe::S*]
} {{} {} ok {} 0 {}}
test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup {
} -body {
set g [interp children]
if {$g ne {}} {
append g { -- residue of an earlier test}
}
set h [info vars ::safe::S*]
if {$h ne {}} {
append h { -- residue of an earlier test}
}
set i [safe::interpCreate foo::bar]
set j [safe::interpCreate [list $i hello::world]]
list $g $h [interp eval $j {join {o k} ""}] \
[foo::bar eval {hello::world eval {join {o k} ""}}] \
[safe::interpDelete $i] \
[interp exists $j] [info vars ::safe::S*]
} -match glob -result {{} {} ok ok {} 0 {}}
test safe-7.4 {positive non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# this time, unlike test safe-7.2, SafeTestPackage1 should be found
list $token1 $token2 -- \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
# Note that the glob match elides directories (those from the module path)
# other than the first and last in the access path.
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\
{TCLLIB * TESTSDIR/auto0/auto1} -- {}}
test safe-7.5 {positive and negative module package require, including ancestor directory issue, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
tcl::tm::path add [file join $TestsDir auto0 modules]
set i [safe::interpCreate]
tcl::tm::path remove [file join $TestsDir auto0 modules]
interp eval $i {
package forget mod1::test1
catch {namespace delete ::mod1}
}
} -body {
# Should raise an error (module ancestor directory issue)
set code1 [catch {interp eval $i {package require test1}} msg1]
# Should not raise an error
set code2 [catch {interp eval $i {package require mod1::test1}} msg2]
return [list $code1 $msg1 $code2]
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package test1} 0}
### 8. Test source control on file name.
test safe-8.1 {safe source control on file} -setup {
set i "a"
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
test safe-9.6 {interpConfigure widget like behaviour} -body {
# this test shall work, don't try to "fix it" unless you *really* know what
# you are doing (ie you are me :p) -- dl
list [set i [safe::interpCreate \
-noStatics \
-nestedLoadOk \
-deleteHook {foo bar}]
| | | | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 |
test safe-9.6 {interpConfigure widget like behaviour} -body {
# this test shall work, don't try to "fix it" unless you *really* know what
# you are doing (ie you are me :p) -- dl
list [set i [safe::interpCreate \
-noStatics \
-nestedLoadOk \
-deleteHook {foo bar}]
safe::interpConfigure $i -accessPath /foo/bar
safe::interpConfigure $i]\
[safe::interpConfigure $i -aCCess]\
[safe::interpConfigure $i -nested]\
[safe::interpConfigure $i -statics]\
[safe::interpConfigure $i -DEL]\
[safe::interpConfigure $i -accessPath /blah -statics 1
safe::interpConfigure $i]\
[safe::interpConfigure $i -deleteHook toto -nosta -nested 0
|
| ︙ | ︙ | |||
762 763 764 765 766 767 768 |
} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\
{-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
{-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\
{-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}}
test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\
{-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
{-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\
{-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}}
test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Load and run the commands.
set code1 [catch {interp eval $i {report1}} msg1]
set code2 [catch {interp eval $i {report2}} msg2]
list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}}
test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Load auto_load data.
interp eval $i {catch nonExistentCommand}
# Load and run the commands.
# This guarantees the test will pass even if the tokens are swapped.
set code1 [catch {interp eval $i {report1}} msg1]
set code2 [catch {interp eval $i {report2}} msg2]
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Run the commands.
set code3 [catch {interp eval $i {report1}} msg3]
set code4 [catch {interp eval $i {report2}} msg4]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}}
test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Load auto_load data.
interp eval $i {catch nonExistentCommand}
# Do not load the commands. With the tokens swapped, the test
# will pass only if the Safe Base has called auto_reset.
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Load and run the commands.
set code3 [catch {interp eval $i {report1}} msg3]
set code4 [catch {interp eval $i {report2}} msg4]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}}
test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
# For complete correspondence to safe-9.10opt, include auto0 in access path.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
# This would have no effect because the records in Pkg of these directories
# were from access as children of {$p(:1:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
0 OK1 0 OK2}
test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-9.11 without path auto0, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- \
$code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
0 OK1 0 OK2}
test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
# Load pkgIndex.tcl data.
|
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 |
set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5]
# Try to load the packages.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
| | | | | | | | | 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 |
set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5]
# Try to load the packages.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
$mappA -- $mappB
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\
1 {* not found in access path} -- 1 1 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}}
test safe-9.20 {check module loading, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
| | | | | | | | | | | | | 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 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} -- res0 res1 res2}
# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in
# tokenized form to the child's access path, and then adds all the
# descendants, discovered recursively by using glob.
# - The order of the directories in the list returned by glob is system-dependent,
# and therefore this is true also for (a) the order of token assignment to
# descendants of the [tcl::tm::list] roots; and (b) the order of those same
# directories in the access path. Both those things must be sorted before
# comparing with expected results. The test is therefore not totally strict,
# but will notice missing or surplus directories.
test safe-9.21 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 1} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
|
| ︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
test safe-9.22 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 0} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
test safe-9.23 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 3} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
|
| ︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
| | | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
| | | | | | | | | | | | | | | | | 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 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
test safe-9.24 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 2 (worst case)} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
|
| ︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
| | | | | | | | | | | | | | | | | | 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
### 10. Test options -statics -nostatics -nested -nestedloadok
catch {teststaticlibrary Safepfx1 0 0}
test safe-10.1 {testing statics loading} -constraints tcl::test -setup {
set i [safe::interpCreate]
} -body {
interp eval $i {load {} Safepfx1}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: cannot use library in a safe interpreter: no Safepfx1_SafeInit procedure}
test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i {load {} Safepfx1}} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: cannot use library in a safe interpreter: no Safepfx1_SafeInit procedure
invoked from within
"load {} Safepfx1"
invoked from within
"interp eval $i {load {} Safepfx1}"}
test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body {
set i [safe::interpCreate -nostatics]
interp eval $i {load {} Safepfx1}
|
| ︙ | ︙ | |||
1398 1399 1400 1401 1402 1403 1404 |
safe::interpDelete $i
} -result {permission denied (nested load)}
test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body {
set i [safe::interpCreate -nestedloadok]
interp eval $i {interp create x; load {} Safepfx1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
| | | | 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
safe::interpDelete $i
} -result {permission denied (nested load)}
test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body {
set i [safe::interpCreate -nestedloadok]
interp eval $i {interp create x; load {} Safepfx1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: cannot use library in a safe interpreter: no Safepfx1_SafeInit procedure}
test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body {
set i [safe::interpCreate -nestedloadok]
catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: cannot use library in a safe interpreter: no Safepfx1_SafeInit procedure
invoked from within
"load {} Safepfx1 x"
invoked from within
"interp eval $i {interp create x; load {} Safepfx1 x}"}
### 11. Safe encoding.
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 |
test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup {
set i [safe::interpCreate]
buildEnvironment deleteme.tm
} -body {
::safe::interpAddToAccessPath $i $testdir2
set result [$i eval glob -nocomplain -directory $testdir2 *.tm]
if {$result eq [list $testfile]} {
| | | | 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 |
test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup {
set i [safe::interpCreate]
buildEnvironment deleteme.tm
} -body {
::safe::interpAddToAccessPath $i $testdir2
set result [$i eval glob -nocomplain -directory $testdir2 *.tm]
if {$result eq [list $testfile]} {
return "glob match"
} else {
return "no match: $result"
}
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {glob match}
test safe-13.3 {cf 13.2 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
set i [safe::interpCreate]
|
| ︙ | ︙ | |||
1620 1621 1622 1623 1624 1625 1626 |
buildEnvironment deleteme.tm
} -body {
::safe::interpAddToAccessPath $i $testdir
::safe::interpAddToAccessPath $i $testdir2
set result [$i eval \
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]]
if {$result eq [list $testfile]} {
| | | | 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
buildEnvironment deleteme.tm
} -body {
::safe::interpAddToAccessPath $i $testdir
::safe::interpAddToAccessPath $i $testdir2
set result [$i eval \
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]]
if {$result eq [list $testfile]} {
return "glob match"
} else {
return "no match: $result"
}
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {glob match}
test safe-13.5 {as 13.4 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
set i [safe::interpCreate]
|
| ︙ | ︙ | |||
1695 1696 1697 1698 1699 1700 1701 |
set i [safe::interpCreate]
buildEnvironment notIndex.tcl
} -body {
::safe::interpAddToAccessPath $i $testdir2
set result [$i eval \
glob -directory $testdir -join -nocomplain * notIndex.tcl]
if {$result eq [list $testfile]} {
| | | | 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 |
set i [safe::interpCreate]
buildEnvironment notIndex.tcl
} -body {
::safe::interpAddToAccessPath $i $testdir2
set result [$i eval \
glob -directory $testdir -join -nocomplain * notIndex.tcl]
if {$result eq [list $testfile]} {
return {glob match}
} else {
return "no match: $result"
}
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {no match: }
test safe-13.10 {as 13.8 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
set i [safe::interpCreate]
|
| ︙ | ︙ | |||
1723 1724 1725 1726 1727 1728 1729 |
### 14. Sanity checks on paths - module path, access path, auto_path.
test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
set tm {}
foreach token [$i eval ::tcl::tm::path list] {
| | | | | | | | | | | | | | | | 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 |
### 14. Sanity checks on paths - module path, access path, auto_path.
test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
set tm {}
foreach token [$i eval ::tcl::tm::path list] {
lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token]
}
return $tm
} -cleanup {
safe::interpDelete $i
} -result [::tcl::tm::path list]
test safe-14.2 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
set i [safe::interpCreate]
} -body {
set autoList {}
set token [lindex [$i eval set ::auto_path] 0]
set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
return [list [lindex $accessList 0] $auto0]
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library]]
test safe-14.2.1 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
set i [safe::interpCreate]
} -body {
set autoList {}
set token [lindex [$i eval set ::auto_path] 0]
set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
set autoList [lindex [safe::interpConfigure $i -autoPath] 1]
return [list [lindex $accessList 0] [lindex $autoList 0] $auto0]
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library] [info library]]
test safe-14.3 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib2 $lib1]
# Unexpected order, should be reversed in the child
set i [safe::interpCreate]
} -body {
set autoList {}
set token [lindex [$i eval set ::auto_path] 0]
set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
return [list [lindex $accessList 0] $auto0]
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library]]
test safe-14.3.1 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib2 $lib1]
# Unexpected order, should be reversed in the child
|
| ︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 |
set autoList [lindex [safe::interpConfigure $i -autoPath] 1]
return [list [lindex $accessList 0] [lindex $autoList 0] $auto0]
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
| | | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
set autoList [lindex [safe::interpConfigure $i -autoPath] 1]
return [list [lindex $accessList 0] [lindex $autoList 0] $auto0]
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library] [info library]]
### 15. Safe file ensemble.
test safe-15.1 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
|
| ︙ | ︙ | |||
1988 1989 1990 1991 1992 1993 1994 |
### 17. Test the use of ::auto_path for loading commands (via tclIndex files)
### and non-module packages (via pkgIndex.tcl files).
### Corresponding tests with Sync Mode on are 7.*
test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
| | | | | 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 |
### 17. Test the use of ::auto_path for loading commands (via tclIndex files)
### and non-module packages (via pkgIndex.tcl files).
### Corresponding tests with Sync Mode on are 7.*
test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
# because the child will use the same value.
set lib1 [info library]
set lib2 [file join $TestsDir auto0]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
|
| ︙ | ︙ | |||
2013 2014 2015 2016 2017 2018 2019 |
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i HeresPackage1
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
| | | | | | | | | | | | | | | | | | | 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 |
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i HeresPackage1
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 1.2.3
test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not have been set by Safe Base:
set auto1 [interp eval $i {set ::auto_path}]
# This does not change the value of option -autoPath:
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
# an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory)
list $auto1 $token1 $token2 $token3 \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\
1 {can't find package SafeTestPackage1}\
{-accessPath {[list $tcl_library \
*/dummy/unixlike/test/path \
$TestsDir/auto0]}\
-statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
# (not a counterpart of safe-7.3)
test safe-17.3 {Check that default auto_path is the same as in the parent interpreter, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate]
} -body {
# This file's header sets auto_path to a single directory [info library],
# which is the one required by Safe Base to be present & first in the list.
set ap {}
foreach token [$i eval set ::auto_path] {
lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token]
}
return [list $ap [lindex [::safe::interpConfigure $i -autoPath] 1]]
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list $::auto_path $::auto_path]
test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not have been set by Safe Base:
set auto1 [interp eval $i {set ::auto_path}]
|
| ︙ | ︙ | |||
2116 2117 2118 2119 2120 2121 2122 |
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 |
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\
{-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\
-statics 0 -nested 1 -deleteHook {}\
-autoPath {}} {}"
test safe-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
tcl::tm::path add [file join $TestsDir auto0 modules]
set i [safe::interpCreate]
tcl::tm::path remove [file join $TestsDir auto0 modules]
interp eval $i {
package forget mod1::test1
catch {namespace delete ::mod1}
}
} -body {
# Should raise an error (tests module ancestor directory rule)
set code1 [catch {interp eval $i {package require test1}} msg1]
# Should not raise an error
set code2 [catch {interp eval $i {package require mod1::test1}} msg2]
return [list $code1 $msg1 $code2]
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package test1} 0}
### 18. Test tokenization of directories available to a child.
test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set i [safe::interpCreate]
} -body {
set badTokens {}
foreach dir [$i eval {set ::auto_path}] {
if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
# Match - OK - token has expected form
} else {
# No match - possibly an ordinary path has not been tokenized
lappend badTokens $dir
}
}
set badTokens
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {}
test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate]
} -body {
set badTokens {}
foreach dir [$i eval {set ::auto_path}] {
if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
# Match - OK - token has expected form
} else {
# No match - possibly an ordinary path has not been tokenized
lappend badTokens $dir
}
}
set badTokens
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {}
test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set i [safe::interpCreate]
} -body {
set badTokens {}
foreach dir [$i eval {::tcl::tm::path list}] {
if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
# Match - OK - token has expected form
} else {
# No match - possibly an ordinary path has not been tokenized
lappend badTokens $dir
}
}
set badTokens
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {}
test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate]
} -body {
set badTokens {}
foreach dir [$i eval {::tcl::tm::path list}] {
if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
# Match - OK - token has expected form
} else {
# No match - possibly an ordinary path has not been tokenized
lappend badTokens $dir
}
}
set badTokens
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {}
### 19. Assorted options, including changes to option values.
### Mostly these are changes to access path, auto_path, module path.
### If Sync Mode is on, a corresponding test with Sync Mode off is 9.*
test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load and run the commands.
set code1 [catch {interp eval $i {report1}} msg1]
set code2 [catch {interp eval $i {report2}} msg2]
list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA -- $mappC -- $toksC
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{{$p(:0:)} {$p(:1:)} {$p(:2:)}}}
test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load auto_load data.
interp eval $i {catch nonExistentCommand}
# Load and run the commands.
# This guarantees the test will pass even if the tokens are swapped.
set code1 [catch {interp eval $i {report1}} msg1]
set code2 [catch {interp eval $i {report2}} msg2]
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappD [mapList $PathMapp [dict get $confB -autoPath]]
set toksD [interp eval $i set ::auto_path]
# Run the commands.
set code3 [catch {interp eval $i {report1}} msg3]
set code4 [catch {interp eval $i {report2}} msg4]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}}
test safe-19.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode off} -constraints {AutoSyncDefined} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load auto_load data.
interp eval $i {catch nonExistentCommand}
# Do not load the commands. With the tokens swapped, the test
# will pass only if the Safe Base has called auto_reset.
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappD [mapList $PathMapp [dict get $confB -autoPath]]
set toksD [interp eval $i set ::auto_path]
# Load and run the commands.
set code3 [catch {interp eval $i {report1}} msg3]
set code4 [catch {interp eval $i {report2}} msg4]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
{{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}}
test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement (1), Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
# This would have no effect because the records in Pkg of these directories
# were from access as children of {$p(:1:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappD [mapList $PathMapp [dict get $confB -autoPath]]
set toksD [interp eval $i set ::auto_path]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD -- \
$code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
{TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\
{{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:1:)}} --\
0 OK1 0 OK2}
test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-19.11 without path auto0, Sync Mode off} -constraints {AutoSyncDefined} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
# To manage without path auto0, use an auto_path that is unusual for
# package discovery.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappD [mapList $PathMapp [dict get $confB -autoPath]]
set toksD [interp eval $i set ::auto_path]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD -- \
$code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1} --\
{{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:1:)} {$p(:2:)}} --\
0 OK1 0 OK2}
test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode off} -constraints {AutoSyncDefined} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
# Path auto0 added (cf. safe-9.3) because it is needed for auto_path.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
|
| ︙ | ︙ | |||
2588 2589 2590 2591 2592 2593 2594 |
set toksD [interp eval $i set ::auto_path]
# Try to load the packages.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 |
set toksD [interp eval $i set ::auto_path]
# Try to load the packages.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
$mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:2:)} {$p(:3:)} -- 1 {* not found in access path} --\
1 {* not found in access path} -- 1 1 --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB*} -- {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\
{{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)}}}
# (no counterpart safe-9.14)
test safe-19.14 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
# Test that although -autoPath is unchanged, the child's ::auto_path changes to
# reflect the changes in token mappings.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Swap tokens {$p(:1:)} and {$p(:3:)}.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto2] \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappD [mapList $PathMapp [dict get $confA -autoPath]]
set toksD [interp eval $i set ::auto_path]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path0 $path1 $path2 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \
$code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} {$p(:1:)} -- {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1 TESTSDIR/auto0*} --\
{TCLLIB TESTSDIR/auto0} --\
{TCLLIB TESTSDIR/auto0} --\
0 OK1 0 OK2}
# (no counterpart safe-9.15)
test safe-19.15 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
# Test that although -autoPath is unchanged, the child's ::auto_path changes to
# reflect the changes in token mappings; and that it is based on the -autoPath
# value, not the previously restricted child ::auto_path.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Add more directories.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
set mappD [mapList $PathMapp [dict get $confA -autoPath]]
set toksD [interp eval $i set ::auto_path]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path0 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \
$code3 $msg3 $code4 $msg4 -- \
$mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} -- {$p(:1:)} {$p(:2:)} {$p(:3:)} -- {{$p(:0:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0*} --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
0 OK1 0 OK2}
# (no counterpart safe-9.16)
test safe-19.16 {default value for -accessPath and -autoPath on creation; -autoPath preserved when -accessPath changes, ::auto_path using changed tokens, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set tmpAutoPath $::auto_path
set ::auto_path [list $tcl_library [file join $TestsDir auto0]]
set i [safe::interpCreate]
set ::auto_path $tmpAutoPath
} -body {
# Test that the -autoPath acquires and keeps the parent's value unless otherwise specified.
# Inspect.
set confA [safe::interpConfigure $i]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load pkgIndex.tcl data.
catch {interp eval $i {package require NOEXIST}}
# Rearrange access path. Remove a directory.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto1]]
# Inspect.
set confB [safe::interpConfigure $i]
set mappB [mapList $PathMapp [dict get $confB -accessPath]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
set mappD [mapList $PathMapp [dict get $confA -autoPath]]
set toksD [interp eval $i set ::auto_path]
# Try to load the packages and run a command from each one.
set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4]
set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
list $path5 $path3 -- [lindex $toksC 0] [llength $toksC] -- \
$toksD -- $code3 $msg3 $code4 $msg4 -- \
$mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:0:)} 2 --\
{{$p(:0:)} {$p(:1:)}} -- 0 1.2.3 1 {can't find package SafeTestPackage2} --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1*} --\
{TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\
0 OK1 1 {invalid command name "HeresPackage2"}}
test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
|
| ︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
| | | | | | | | | | | | | | 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} -- res0 res1 res2}
# See comments on lsort after test safe-9.20.
test safe-19.21 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 1} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
|
| ︙ | ︙ | |||
2879 2880 2881 2882 2883 2884 2885 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 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 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
test safe-19.22 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 0} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
set modsA [interp eval $i {tcl::tm::path list}]
set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
test safe-19.23 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 3} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
|
| ︙ | ︙ | |||
2999 3000 3001 3002 3003 3004 3005 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
| | | | 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
|
| ︙ | ︙ | |||
3023 3024 3025 3026 3027 3028 3029 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
| | | | | | | | | | | | | | | | | | 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 |
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
test safe-19.24 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 2 (worst case)} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $TestsDir auto0 modules]
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library]]
# Inspect.
set confA [safe::interpConfigure $i]
|
| ︙ | ︙ | |||
3076 3077 3078 3079 3080 3081 3082 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 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 |
catch {interp eval $i {package require NOEXIST}}
catch {interp eval $i {package require mod1::NOEXIST}}
catch {interp eval $i {package require mod2::NOEXIST}}
# Add to access path.
# This injects more tokens, pushing modules to higher token numbers.
safe::interpConfigure $i -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]
# Inspect.
set confB [safe::interpConfigure $i]
set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
set modsB [interp eval $i {tcl::tm::path list}]
set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
# Try to load the packages and run a command from each one.
set code0 [catch {interp eval $i {package require test0}} msg0]
set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
set out0 [interp eval $i {test0::try0}]
set out1 [interp eval $i {mod1::test1::try1}]
set out2 [interp eval $i {mod2::test2::try2}]
list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
[lsort [list $path3 $path4 $path5]] -- $modsB -- \
$code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
$out0 $out1 $out2
} -cleanup {
tcl::tm::path remove [file join $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
### 20. safe::interpCreate with different cases of -accessPath, -autoPath.
set ::auto_path [list $tcl_library [file dirname $tcl_library] [file join $TestsDir auto0]]
test safe-20.1 "create -accessPath NULL -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list $::auto_path -- $::auto_path]
test safe-20.2 "create -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath {}]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list $::auto_path -- $::auto_path]
test safe-20.3 "create -accessPath path1 -autoPath NULL -> {}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1]]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {{} -- {}}
test safe-20.4 "create -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -autoPath {}]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {{} -- {}}
test safe-20.5 "create -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath {} -autoPath {}]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {{} -- {}}
test safe-20.6 "create -accessPath path1 -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath {}]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {{} -- {}}
test safe-20.7 "create -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -autoPath [lrange $::auto_path 0 0]]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
test safe-20.8 "create -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath {} -autoPath [lrange $::auto_path 0 0]]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
test safe-20.9 "create -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
test safe-20.10 "create -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -autoPath /not/in/access/path]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {/not/in/access/path -- {}}
test safe-20.11 "create -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath {} -autoPath /not/in/access/path]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {/not/in/access/path -- {}}
test safe-20.12 "create -accessPath path1 -autoPath pathX -> {pathX}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath /not/in/access/path]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {/not/in/access/path -- {}}
### 21. safe::interpConfigure with different cases of -accessPath, -autoPath.
test safe-21.1 "interpConfigure -accessPath NULL -autoPath NULL -> no change" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -deleteHook {}
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
test safe-21.2 "interpConfigure -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath {}
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list $::auto_path -- $::auto_path]
test safe-21.3 "interpConfigure -accessPath path1 -autoPath NULL -> no change" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath [lrange $::auto_path 0 1]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
test safe-21.4 "interpConfigure -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -autoPath {}
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {{} -- {}}
test safe-21.5 "interpConfigure -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath {} -autoPath {}
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {{} -- {}}
test safe-21.6 "interpConfigure -accessPath {path1} -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath [lrange $::auto_path 1 1] -autoPath {}
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {{} -- {}}
test safe-21.7 "interpConfigure -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -autoPath [lrange $::auto_path 1 1]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]]
test safe-21.8 "interpConfigure -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath {} -autoPath [lrange $::auto_path 1 1]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]]
test safe-21.9 "interpConfigure -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath [lrange $::auto_path 1 1]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]]
test safe-21.10 "interpConfigure -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -autoPath /not/in/access/path
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {/not/in/access/path -- {}}
test safe-21.11 "interpConfigure -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath {} -autoPath /not/in/access/path
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {/not/in/access/path -- {}}
test safe-21.12 "interpConfigure -accessPath path1 -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
} -body {
safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath /not/in/access/path
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {/not/in/access/path -- {}}
# cleanup
set ::auto_path $SaveAutoPath
unset SaveAutoPath TestsDir PathMapp
rename getAutoPath {}
|
| ︙ | ︙ |
Changes to tests/scan.test.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 |
default {
return 0
}
}
}
testConstraint ieeeFloatingPoint [testIEEE]
| < | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
default {
return 0
}
}
}
testConstraint ieeeFloatingPoint [testIEEE]
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
list [scan \]foo {%[]f]} x] $x
} {1 \]f}
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
#
test scan-5.11 {integer scanning} -constraints {nonPortable} -setup {
set a {}; set b {}
} -body {
list [scan "4294967280 4294967280" "%u %d" a b] $a \
[expr {$b == -16 || $b == 0x7fffffff}]
} -result {2 4294967280 1}
| | | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 |
#
test scan-5.11 {integer scanning} -constraints {nonPortable} -setup {
set a {}; set b {}
} -body {
list [scan "4294967280 4294967280" "%u %d" a b] $a \
[expr {$b == -16 || $b == 0x7fffffff}]
} -result {2 4294967280 1}
test scan-5.12 {integer scanning} -setup {
set a {}; set b {}; set c {}
} -body {
list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
%ld,%lx,%lo a b c] $a $b $c
} -result {3 7810179016327718216 7810179016327718216 7810179016327718216}
test scan-5.13 {integer scanning and overflow} {
# This test used to fail on some 64-bit systems. [Bug 1011860]
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 |
list [scan "-207698809136909011942886895" \
%llu a] $a
} -returnCodes 1 -result {unsigned bignum scans are invalid}
test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
| | > > > > > | 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 |
list [scan "-207698809136909011942886895" \
%llu a] $a
} -returnCodes 1 -result {unsigned bignum scans are invalid}
test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
%llu a] $a
} -result {1 207698809136909011942886895}
test scan-5.20 {ignore digit separators} -setup {
set a {}; set b {}; set c {};
} -body {
list [scan "10_23_45" %d_%d_%d a b c] $a $b $c
} -result {3 10 23 45}
test scan-5.21 {integer scanning, %j, %q, &z, %t} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "42 43 44 45" "%jd %qd %zd %td" a b c d] $a $b $c $d
} -result {4 42 43 44 45}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
} -result {3 2.1 -300000000.0 0.99962 {}}
test scan-6.2 {floating-point scanning} -setup {
|
| ︙ | ︙ |
Changes to tests/set-old.test.
| ︙ | ︙ | |||
343 344 345 346 347 348 349 |
} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
| | | | | | | | | | | | | | 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 |
} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array anymore a x]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.9 {array command, donesearch option} {
catch {unset a}
list [catch {array donesearch a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.10 {array command, donesearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array donesearch a x]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.11 {array command, exists option} {
list [catch {array exists a b} msg] $msg
} {1 {wrong # args: should be "array exists arrayName"}}
test set-old-8.12 {array command, exists option} {
catch {unset a}
array exists a
} {0}
test set-old-8.13 {array command, exists option} {
catch {unset a}
set a(0) 1
array exists a
} {1}
test set-old-8.14 {array command, exists option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array exists a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 0}
test set-old-8.15 {array command, get option} {
list [catch {array get} msg] $msg
} {1 {wrong # args: should be "array get arrayName ?pattern?"}}
test set-old-8.16 {array command, get option} {
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 |
set a(x3) 5
set a(b1) 24
set a(b2) 25
lsort [array get a x*]
} {3 4 5 x1 x2 x3}
test set-old-8.21 {array command, get option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
| | | | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
set a(x3) 5
set a(b1) 24
set a(b2) 25
lsort [array get a x*]
} {3 4 5 x1 x2 x3}
test set-old-8.21 {array command, get option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array get a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.22 {array command, names option} {
catch {unset a}
set a(22) 3
list [catch {array names a 4 5} msg] $msg
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
set a(bxy) 44
set a(no) yes
set a(xxx) value
list [lsort [array names a *xy]] [lsort [array names a]]
} {{axy bxy} {axy bxy no xxx}}
test set-old-8.28 {array command, names option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
| | | | | | | | | | 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 |
set a(bxy) 44
set a(no) yes
set a(xxx) value
list [lsort [array names a *xy]] [lsort [array names a]]
} {{axy bxy} {axy bxy no xxx}}
test set-old-8.28 {array command, names option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array names a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.29 {array command, nextelement option} {
list [catch {array nextelement a} msg] $msg
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
test set-old-8.30 {array command, nextelement option} {
catch {unset a}
list [catch {array nextelement a b} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.31 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array nextelement a b]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.32 {array command, set option} {
list [catch {array set a} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
test set-old-8.33 {array command, set option} {
|
| ︙ | ︙ | |||
506 507 508 509 510 511 512 |
catch {unset a}
set a(xx) yy
array set a {b c d e}
lsort [array get a]
} {b c d e xx yy}
test set-old-8.37 {array command, set option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
| | | | | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
catch {unset a}
set a(xx) yy
array set a {b c d e}
lsort [array get a]
} {b c d e xx yy}
test set-old-8.37 {array command, set option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array set a {x 0}]
}
set a(x)
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.38 {array command, set option} {
catch {unset aVaRnAmE}
array set aVaRnAmE {}
list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 |
catch {unset a}
set a(22) 3;
trace add var a(33) {read write unset} ignore
list [catch {array size a} msg] $msg
} {0 1}
test set-old-8.45 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
| | | | | | | | | | 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 |
catch {unset a}
set a(22) 3;
trace add var a(33) {read write unset} ignore
list [catch {array size a} msg] $msg
} {0 1}
test set-old-8.45 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array size a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 0}
test set-old-8.46 {array command, startsearch option} {
list [catch {array startsearch a b} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
test set-old-8.47 {array command, startsearch option} {
catch {unset a}
list [catch {array startsearch a} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.48 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
catch {rename p ""}
proc p {x} {
if {$x==1} {
return [array startsearch a]
}
set a(x) 123
}
list [catch {p 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.49 {array command, statistics option} {
catch {unset a}
set a(abc) 1
set a(def) 2
|
| ︙ | ︙ |
Changes to tests/set.test.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
test set-1.10 {TclCompileSetCmd: only two args => just getting value} {
set i {one two}
set i
} {one two}
test set-1.11 {TclCompileSetCmd: simple global name} {
proc p {} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test set-1.10 {TclCompileSetCmd: only two args => just getting value} {
set i {one two}
set i
} {one two}
test set-1.11 {TclCompileSetCmd: simple global name} {
proc p {} {
global i
set i 54
set i
}
p
} {54}
test set-1.12 {TclCompileSetCmd: simple local name} {
proc p {bar} {
set foo $bar
set foo
}
p 999
} {999}
test set-1.13 {TclCompileSetCmd: simple but new (unknown) local name} {
proc p {} {
set bar
}
catch {p} msg
set msg
} {can't read "bar": no such variable}
test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} {
proc 260locals {} {
# create 260 locals (the last ones with index > 255)
set a0 0; set a1 0; set a2 0; set a3 0; set a4 0
set a5 0; set a6 0; set a7 0; set a8 0; set a9 0
set b0 0; set b1 0; set b2 0; set b3 0; set b4 0
set b5 0; set b6 0; set b7 0; set b8 0; set b9 0
set c0 0; set c1 0; set c2 0; set c3 0; set c4 0
set c5 0; set c6 0; set c7 0; set c8 0; set c9 0
set d0 0; set d1 0; set d2 0; set d3 0; set d4 0
set d5 0; set d6 0; set d7 0; set d8 0; set d9 0
set e0 0; set e1 0; set e2 0; set e3 0; set e4 0
set e5 0; set e6 0; set e7 0; set e8 0; set e9 0
set f0 0; set f1 0; set f2 0; set f3 0; set f4 0
set f5 0; set f6 0; set f7 0; set f8 0; set f9 0
set g0 0; set g1 0; set g2 0; set g3 0; set g4 0
set g5 0; set g6 0; set g7 0; set g8 0; set g9 0
set h0 0; set h1 0; set h2 0; set h3 0; set h4 0
set h5 0; set h6 0; set h7 0; set h8 0; set h9 0
set i0 0; set i1 0; set i2 0; set i3 0; set i4 0
set i5 0; set i6 0; set i7 0; set i8 0; set i9 0
set j0 0; set j1 0; set j2 0; set j3 0; set j4 0
set j5 0; set j6 0; set j7 0; set j8 0; set j9 0
set k0 0; set k1 0; set k2 0; set k3 0; set k4 0
set k5 0; set k6 0; set k7 0; set k8 0; set k9 0
set l0 0; set l1 0; set l2 0; set l3 0; set l4 0
set l5 0; set l6 0; set l7 0; set l8 0; set l9 0
set m0 0; set m1 0; set m2 0; set m3 0; set m4 0
set m5 0; set m6 0; set m7 0; set m8 0; set m9 0
set n0 0; set n1 0; set n2 0; set n3 0; set n4 0
set n5 0; set n6 0; set n7 0; set n8 0; set n9 0
set o0 0; set o1 0; set o2 0; set o3 0; set o4 0
set o5 0; set o6 0; set o7 0; set o8 0; set o9 0
set p0 0; set p1 0; set p2 0; set p3 0; set p4 0
set p5 0; set p6 0; set p7 0; set p8 0; set p9 0
set q0 0; set q1 0; set q2 0; set q3 0; set q4 0
set q5 0; set q6 0; set q7 0; set q8 0; set q9 0
set r0 0; set r1 0; set r2 0; set r3 0; set r4 0
set r5 0; set r6 0; set r7 0; set r8 0; set r9 0
set s0 0; set s1 0; set s2 0; set s3 0; set s4 0
set s5 0; set s6 0; set s7 0; set s8 0; set s9 0
set t0 0; set t1 0; set t2 0; set t3 0; set t4 0
set t5 0; set t6 0; set t7 0; set t8 0; set t9 0
set u0 0; set u1 0; set u2 0; set u3 0; set u4 0
set u5 0; set u6 0; set u7 0; set u8 0; set u9 0
set v0 0; set v1 0; set v2 0; set v3 0; set v4 0
set v5 0; set v6 0; set v7 0; set v8 0; set v9 0
set w0 0; set w1 0; set w2 0; set w3 0; set w4 0
set w5 0; set w6 0; set w7 0; set w8 0; set w9 0
set x0 0; set x1 0; set x2 0; set x3 0; set x4 0
set x5 0; set x6 0; set x7 0; set x8 0; set x9 0
set y0 0; set y1 0; set y2 0; set y3 0; set y4 0
set y5 0; set y6 0; set y7 0; set y8 0; set y9 0
set z0 0; set z1 0; set z2 0; set z3 0; set z4 0
set z5 0; set z6 0; set z7 0; set z8 0; set z9 1234
}
260locals
} {1234}
test set-1.15 {TclCompileSetCmd: variable is array} -setup {
catch {unset a}
} -body {
set x 27
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
$z i {one two}
$z i
} {one two}
test set-3.11 {uncompiled set command: simple global name} {
proc p {} {
set z set
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
$z i {one two}
$z i
} {one two}
test set-3.11 {uncompiled set command: simple global name} {
proc p {} {
set z set
global i
$z i 54
$z i
}
p
} {54}
test set-3.12 {uncompiled set command: simple local name} {
proc p {bar} {
set z set
$z foo $bar
$z foo
}
p 999
} {999}
test set-3.13 {uncompiled set command: simple but new (unknown) local name} {
set z set
proc p {} {
set z set
$z bar
}
catch {p} msg
$z msg
} {can't read "bar": no such variable}
test set-3.14 {uncompiled set command: simple local name, >255 locals} {
proc 260locals {} {
set z set
# create 260 locals (the last ones with index > 255)
$z a0 0; $z a1 0; $z a2 0; $z a3 0; $z a4 0
$z a5 0; $z a6 0; $z a7 0; $z a8 0; $z a9 0
$z b0 0; $z b1 0; $z b2 0; $z b3 0; $z b4 0
$z b5 0; $z b6 0; $z b7 0; $z b8 0; $z b9 0
$z c0 0; $z c1 0; $z c2 0; $z c3 0; $z c4 0
$z c5 0; $z c6 0; $z c7 0; $z c8 0; $z c9 0
$z d0 0; $z d1 0; $z d2 0; $z d3 0; $z d4 0
$z d5 0; $z d6 0; $z d7 0; $z d8 0; $z d9 0
$z e0 0; $z e1 0; $z e2 0; $z e3 0; $z e4 0
$z e5 0; $z e6 0; $z e7 0; $z e8 0; $z e9 0
$z f0 0; $z f1 0; $z f2 0; $z f3 0; $z f4 0
$z f5 0; $z f6 0; $z f7 0; $z f8 0; $z f9 0
$z g0 0; $z g1 0; $z g2 0; $z g3 0; $z g4 0
$z g5 0; $z g6 0; $z g7 0; $z g8 0; $z g9 0
$z h0 0; $z h1 0; $z h2 0; $z h3 0; $z h4 0
$z h5 0; $z h6 0; $z h7 0; $z h8 0; $z h9 0
$z i0 0; $z i1 0; $z i2 0; $z i3 0; $z i4 0
$z i5 0; $z i6 0; $z i7 0; $z i8 0; $z i9 0
$z j0 0; $z j1 0; $z j2 0; $z j3 0; $z j4 0
$z j5 0; $z j6 0; $z j7 0; $z j8 0; $z j9 0
$z k0 0; $z k1 0; $z k2 0; $z k3 0; $z k4 0
$z k5 0; $z k6 0; $z k7 0; $z k8 0; $z k9 0
$z l0 0; $z l1 0; $z l2 0; $z l3 0; $z l4 0
$z l5 0; $z l6 0; $z l7 0; $z l8 0; $z l9 0
$z m0 0; $z m1 0; $z m2 0; $z m3 0; $z m4 0
$z m5 0; $z m6 0; $z m7 0; $z m8 0; $z m9 0
$z n0 0; $z n1 0; $z n2 0; $z n3 0; $z n4 0
$z n5 0; $z n6 0; $z n7 0; $z n8 0; $z n9 0
$z o0 0; $z o1 0; $z o2 0; $z o3 0; $z o4 0
$z o5 0; $z o6 0; $z o7 0; $z o8 0; $z o9 0
$z p0 0; $z p1 0; $z p2 0; $z p3 0; $z p4 0
$z p5 0; $z p6 0; $z p7 0; $z p8 0; $z p9 0
$z q0 0; $z q1 0; $z q2 0; $z q3 0; $z q4 0
$z q5 0; $z q6 0; $z q7 0; $z q8 0; $z q9 0
$z r0 0; $z r1 0; $z r2 0; $z r3 0; $z r4 0
$z r5 0; $z r6 0; $z r7 0; $z r8 0; $z r9 0
$z s0 0; $z s1 0; $z s2 0; $z s3 0; $z s4 0
$z s5 0; $z s6 0; $z s7 0; $z s8 0; $z s9 0
$z t0 0; $z t1 0; $z t2 0; $z t3 0; $z t4 0
$z t5 0; $z t6 0; $z t7 0; $z t8 0; $z t9 0
$z u0 0; $z u1 0; $z u2 0; $z u3 0; $z u4 0
$z u5 0; $z u6 0; $z u7 0; $z u8 0; $z u9 0
$z v0 0; $z v1 0; $z v2 0; $z v3 0; $z v4 0
$z v5 0; $z v6 0; $z v7 0; $z v8 0; $z v9 0
$z w0 0; $z w1 0; $z w2 0; $z w3 0; $z w4 0
$z w5 0; $z w6 0; $z w7 0; $z w8 0; $z w9 0
$z x0 0; $z x1 0; $z x2 0; $z x3 0; $z x4 0
$z x5 0; $z x6 0; $z x7 0; $z x8 0; $z x9 0
$z y0 0; $z y1 0; $z y2 0; $z y3 0; $z y4 0
$z y5 0; $z y6 0; $z y7 0; $z y8 0; $z y9 0
$z z0 0; $z z1 0; $z z2 0; $z z3 0; $z z4 0
$z z5 0; $z z6 0; $z z7 0; $z z8 0; $z z9 1234
}
260locals
} {1234}
test set-3.15 {uncompiled set command: variable is array} {
set z set
catch {unset a}
$z x 27
|
| ︙ | ︙ |
Changes to tests/socket.test.
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
set port [expr {int(rand()*16383+49152)}]
}
return $port
}
# Check if testsocket testflags is available
testConstraint testsocket_testflags [expr {![catch {
| | | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
set port [expr {int(rand()*16383+49152)}]
}
return $port
}
# Check if testsocket testflags is available
testConstraint testsocket_testflags [expr {![catch {
set h [socket -async localhost [randport]]
testsocket testflags $h 0
close $h
}]}]
# Test the latency of tcp connections over the loopback interface. Some OSes
# (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes
# up to 200ms for a packet sent to localhost to arrive. We're measuring this
# here, so that OSes that don't have this problem can run the tests at full
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
set remoteServerIP $env(remoteServerIP)
}
}
if {![info exists remoteServerPort]} {
if {[info exists env(remoteServerPort)]} {
set remoteServerPort $env(remoteServerPort)
} else {
| | | | | | 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 |
set remoteServerIP $env(remoteServerIP)
}
}
if {![info exists remoteServerPort]} {
if {[info exists env(remoteServerPort)]} {
set remoteServerPort $env(remoteServerPort)
} else {
if {[info exists remoteServerIP]} {
set remoteServerPort 2048
}
}
}
if 0 {
# activate this to time the tests
proc test {args} {
set name [lindex $args 0]
puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name"
}
}
foreach {af localhost} {
inet 127.0.0.1
inet6 ::1
} {
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
foreach {af localhost} {
any 127.0.0.1
inet 127.0.0.1
inet6 ::1
} {
if {![testConstraint supported_$af]} {
| | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
foreach {af localhost} {
any 127.0.0.1
inet 127.0.0.1
inet6 ::1
} {
if {![testConstraint supported_$af]} {
continue
}
set ::tcl::unsupported::socketAF $af
#
# Check if we're supposed to do tests against the remote server
#
set doTestsWithRemoteServer 1
|
| ︙ | ︙ | |||
249 250 251 252 253 254 255 |
}
}
# Some tests are run only if we are doing testing against a remote server.
testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer
if {!$doTestsWithRemoteServer} {
if {[string first s $::tcltest::verbose] >= 0} {
| | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
}
}
# Some tests are run only if we are doing testing against a remote server.
testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer
if {!$doTestsWithRemoteServer} {
if {[string first s $::tcltest::verbose] >= 0} {
puts "Skipping tests with remote server. See tests/socket.test for"
puts "information on how to run remote server."
puts "Reason for not doing remote tests: $noRemoteTestReason"
}
}
#
# If we do the tests, define a command to send a command to the remote server.
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
while {1} {
set line [gets $commandSocket]
if {[eof $commandSocket]} {
error "remote server disappaered"
}
if {$line eq "--Marker--Marker--Marker--"} {
lassign $result code info value
| | | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
while {1} {
set line [gets $commandSocket]
if {[eof $commandSocket]} {
error "remote server disappaered"
}
if {$line eq "--Marker--Marker--Marker--"} {
lassign $result code info value
return -code $code -errorinfo $info $value
}
append result $line "\n"
}
}
}
proc getPort sock {
lindex [fconfigure $sock -sockname] 2
}
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 |
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timed_out"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
set x done
| | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timed_out"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
set x done
close $file
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
} -result {ready done {}}
test socket_$af-2.2 {tcp connection with client port specified} -setup {
set port [randport]
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
| | | | | | | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 |
} -result {ready done {}}
test socket_$af-2.2 {tcp connection with client port specified} -setup {
set port [randport]
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file] $port"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 |
close $f
} -result {ready 1}
test socket_$af-2.3 {tcp connection with client interface specified} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
| | | | | | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
close $f
} -result {ready 1}
test socket_$af-2.3 {tcp connection with client interface specified} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file] $addr"
close $file
set x done
}
puts [lindex [fconfigure $f -sockname] 2]
puts ready
vwait x
after cancel $timer
close $f
}
|
| ︙ | ︙ | |||
467 468 469 470 471 472 473 |
} -result [list ready [list hello $localhost]]
test socket_$af-2.4 {tcp connection with server interface specified} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f [list set localhost $localhost]
puts $f {
set timer [after 2000 "set x done"]
| | | | | | | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
} -result [list ready [list hello $localhost]]
test socket_$af-2.4 {tcp connection with server interface specified} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f [list set localhost $localhost]
puts $f {
set timer [after 2000 "set x done"]
set f [socket -server accept -myaddr $localhost 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
|
| ︙ | ︙ | |||
500 501 502 503 504 505 506 |
close $f
} -result {ready hello}
test socket_$af-2.5 {tcp connection with redundant server port} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
| | | | | | | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
close $f
} -result {ready hello}
test socket_$af-2.5 {tcp connection with redundant server port} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
|
| ︙ | ︙ | |||
545 546 547 548 549 550 551 |
test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_$af stdio] -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {s a p} {
| | | | | | | | | | | 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 |
test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_$af stdio] -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -translation lf -buffering line
}
proc echo {s} {
set l [gets $s]
if {[eof $s]} {
global x
close $s
set x done
} else {
puts $s $l
}
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 |
close $f
} -result {{hello abcdefghijklmnop} done}
removeFile script
test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup {
set path(script) [makeFile {
set f [socket -server accept 0]
proc accept {s a p} {
| | | | | | | | | | | | | | 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 |
close $f
} -result {{hello abcdefghijklmnop} done}
removeFile script
test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup {
set path(script) [makeFile {
set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global i
set l [gets $s]
if {[eof $s]} {
global x
close $s
set x done
} else {
incr i
puts $s $l
}
}
set i 0
puts ready
puts [lindex [fconfigure $f -sockname] 2]
set timer [after 20000 "set x done"]
vwait x
after cancel $timer
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 |
set s [socket -server accept -myaddr $localhost 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global x
| | | | | | | | | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 |
set s [socket -server accept -myaddr $localhost 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global x
set l [gets $s]
if {[eof $s]} {
close $s
set x done
} else {
puts $s $l
}
}
puts ready
puts [lindex [fconfigure $s -sockname] 2]
vwait x
after cancel $t1
vwait x
after cancel $t2
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 |
} -constraints [list socket supported_$af stdio] -body {
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
}
proc echo {s} {
global x
| | | | | | | | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 |
} -constraints [list socket supported_$af stdio] -body {
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
}
proc echo {s} {
global x
set l [gets $s]
if {[eof $s]} {
close $s
set x done
} else {
puts $s $l
}
}
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
set s [socket -server accept -myaddr $localhost 0]
set listen [lindex [fconfigure $s -sockname] 2]
puts $p1 $listen
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
close [socket -server dodo -myaddr $localhost 0x3000]
return ok
} -constraints [list socket supported_$af] -result ok
test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x1} msg]} {
close $msg
| | | 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 |
close [socket -server dodo -myaddr $localhost 0x3000]
return ok
} -constraints [list socket supported_$af] -result ok
test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x1} msg]} {
close $msg
return {htons problem, should be disallowed, are you running as SU?}
}
return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot notOSX notWindows] -result {couldn't open socket: not owner}
test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x10000} msg]} {
close $msg
return {port resolution problem, should be disallowed}
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 |
vwait x
lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
} -cleanup {
after cancel $timer
close $s
close $s1
} -result [list $localhost 1 3]
test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does, check
# that you have these patches installed (using showrev -p):
#
# 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
# 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
| > > > > > > > > > > > > > > > > > > > | 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 |
vwait x
lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
} -cleanup {
after cancel $timer
close $s
close $s1
} -result [list $localhost 1 3]
test socket_$af-7.6 {testing socket specific options - bug e589d9bdab} -setup {
set timer [after 10000 "set x timed_out"]
set l ""
} -constraints [list socket supported_$af unixOrWin] -body {
set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
set listen [lindex [fconfigure $s -sockname] 2]
set s1 [socket $localhost $listen]
vwait x
lsort [dict keys [fconfigure $s1]]
} -cleanup {
after cancel $timer
close $s
close $s1
} -result {-blocking -buffering -buffersize -encoding -eofchar -keepalive -nodelay -peername -profile -sockname -translation}
test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does, check
# that you have these patches installed (using showrev -p):
#
# 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
# 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
|
| ︙ | ︙ | |||
1476 1477 1478 1479 1480 1481 1482 |
proc accept {s a p} {expr {10 / 0}}
sendCommand "set port [getPort $s]"
if {[catch {
sendCommand {
set peername [fconfigure $callerSocket -peername]
set s [socket [lindex $peername 0] $port]
close $s
| | | 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 |
proc accept {s a p} {expr {10 / 0}}
sendCommand "set port [getPort $s]"
if {[catch {
sendCommand {
set peername [fconfigure $callerSocket -peername]
set s [socket [lindex $peername 0] $port]
close $s
}
} msg]} then {
close $s
error $msg
}
vwait x
return $x
} -cleanup {
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 |
set f [socket -server accept -myaddr $localhost 0]
proc accept { file addr port } {
close $file
}
exec $tcltest $delay &
puts [lindex [fconfigure $f -sockname] 2]
close $f
| | | 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 |
set f [socket -server accept -myaddr $localhost 0]
proc accept { file addr port } {
close $file
}
exec $tcltest $delay &
puts [lindex [fconfigure $f -sockname] 2]
close $f
exit
}
close $f
} -constraints [list socket supported_$af stdio exec] -body {
# Launch script2 and wait 5 seconds
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
# If we can still connect to the server, the socket got inherited.
|
| ︙ | ︙ | |||
1702 1703 1704 1705 1706 1707 1708 |
# script1 and exits. If the child process inherited the client socket, the
# socket will still be open.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts $f [list set delay $path(script1)]
puts $f [list set localhost $localhost]
puts $f {
| | | | | | | 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 |
# script1 and exits. If the child process inherited the client socket, the
# socket will still be open.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts $f [list set delay $path(script1)]
puts $f [list set localhost $localhost]
puts $f {
gets stdin port
set f [socket $localhost $port]
exec $tcltest $delay &
puts $f testing
flush $f
exit
}
close $f
# If the socket doesn't hit end-of-file in 10 seconds, the script1 process
# must have inherited the client.
set timeout 0
set after [after 10000 {set x "client socket was inherited"}]
} -constraints [list socket supported_$af stdio exec] -body {
# Create the server socket
set server [socket -server accept -myaddr $localhost 0]
proc accept { file host port } {
# When the client connects, establish the read handler
global server
close $server
fileevent $file readable [list getdata $file]
fconfigure $file -buffering line -blocking 0
set ::f $file
}
proc getdata { file } {
# Read handler on the accepted socket.
global x
set status [catch {read $file} data]
if {$status != 0} {
set x "read failed, error was $data"
} elseif {$data ne ""} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
set x "client socket was not inherited"
} else {
set x "impossible case"
}
}
# Launch the script2 process
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" w]
|
| ︙ | ︙ | |||
1771 1772 1773 1774 1775 1776 1777 |
puts $f [list set localhost $localhost]
puts $f {
set server [socket -server accept -myaddr $localhost 0]
proc accept { file host port } {
global tcltest delay
puts $file {test data on socket}
exec $tcltest $delay &
| | | 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 |
puts $f [list set localhost $localhost]
puts $f {
set server [socket -server accept -myaddr $localhost 0]
proc accept { file host port } {
global tcltest delay
puts $file {test data on socket}
exec $tcltest $delay &
after idle exit
}
puts stdout [lindex [fconfigure $server -sockname] 2]
vwait forever
}
close $f
} -constraints [list socket supported_$af stdio exec] -body {
# Launch the script2 process and connect to it. See how long the socket
|
| ︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 |
global failed
set status [catch {read $file} data]
if {$status != 0} {
set x "read failed, error was $data"
} elseif {[string compare {} $data]} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
global failed
set status [catch {read $file} data]
if {$status != 0} {
set x "read failed, error was $data"
} elseif {[string compare {} $data]} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
set x "accepted socket was not inherited"
} else {
set x "impossible case"
}
return
}
vwait x
set x
} -cleanup {
fconfigure $f -blocking 1
close $f
after cancel $after
close $p
} -result {accepted socket was not inherited}
test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
# create a thread
set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] {
set f [socket -server accept -myaddr @localhost@ 0]
set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global i
set l [gets $s]
if {[eof $s]} {
global x
close $s
set x done
} else {
incr i
puts $s $l
}
}
set i 0
vwait x
close $f
}]]
set port [thread::send $serverthread {set listen}]
set s [socket $localhost $port]
fconfigure $s -buffering line
catch {
puts $s "hello"
gets $s result
}
close $s
thread::release $serverthread
append result " " [llength [thread::names]]
} -result {hello 1} -constraints [list socket supported_$af thread]
proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} {
try {
set ::count 0
set ::testmode $testmode
set port 0
set srvsock {}
# if binding on port 0 is not possible (system related, blocked on ISPs etc):
if {[catch {close [socket -async $::localhost $port]}]} {
# simplest server on random port (immediately closing a connect):
set port [randport]
set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
# socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
}
}
tcltest::DebugPuts 2 "== test \[$::localhost\]:$port $testmode =="
set ::parent [thread::id]
# helper thread creating async connection and initiating transfer (detach) to parent:
set ::helper [thread::create]
thread::send -async $::helper [list \
lassign [list $::parent $::localhost $port $testmode] \
::parent ::localhost ::port ::testmode
]
thread::send -async $::helper {
set ::helper [thread::id]
proc iteration {args} {
set fd [socket -async $::localhost $::port]
if {"helper-writable" in $::testmode} {;# to test both sides during connect
fileevent $fd writable [list apply {{fd} {
if {[thread::id] ne $::helper} {
thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"}
close $fd
return
}
}} $fd]
};#
thread::detach $fd
thread::send -async $::parent [list transf_parent $fd {*}$args]
}
iteration first
}
# parent proc committing transfer attempt (attach) and checking acquire was successful:
proc transf_parent {fd args} {
tcltest::DebugPuts 2 "** trma / $::count ** $args **"
thread::attach $fd
if {"parent-close" in $::testmode} {;# to test close during connect
set ::count $::count
close $fd
return
};#
fileevent $fd writable [list apply {{fd} {
if {[thread::id] ne $::parent} {
thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"}
close $fd
return
}
set ::count $::count
close $fd
}} $fd]
}
# repeat maxIter times (up to maxTime ms as timeout):
set tout [after $maxTime {set ::count "TIMEOUT"}]
while 1 {
vwait ::count
if {![string is integer $::count]} {
# if timeout just skip (test was successful until now):
if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"}
break
}
if {[incr ::count] >= $maxIter} break
tcltest::DebugPuts 2 "** iter / $::count **"
thread::send -async $::helper [list iteration nr $::count]
}
update
set ::count
|
| ︙ | ︙ | |||
1967 1968 1969 1970 1971 1972 1973 |
catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
test socket-14.0.0 {[socket -async] when server only listens on IPv4} \
-constraints {socket supported_inet localhost_v4} \
-setup {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 |
catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
test socket-14.0.0 {[socket -async] when server only listens on IPv4} \
-constraints {socket supported_inet localhost_v4} \
-setup {
proc accept {s a p} {
global x
puts $s bye
close $s
set x ok
}
set server [socket -server accept -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set client [socket -async localhost $port]
set after [after $latency {set x [fconfigure $client -error]}]
vwait x
set x
} -cleanup {
after cancel $after
close $server
close $client
unset x
} -result ok
test socket-14.0.1 {[socket -async] when server only listens on IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
-setup {
proc accept {s a p} {
global x
puts $s bye
close $s
set x ok
}
set server [socket -server accept -myaddr ::1 0]
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set client [socket -async localhost $port]
set after [after $latency {set x [fconfigure $client -error]}]
vwait x
set x
} -cleanup {
after cancel $after
close $server
close $client
unset x
} -result ok
test socket-14.1 {[socket -async] fileevent while still connecting} \
-constraints {socket} \
-setup {
proc accept {s a p} {
global x
puts $s bye
close $s
lappend x ok
}
set server [socket -server accept -myaddr localhost 0]
set port [lindex [fconfigure $server -sockname] 2]
set x ""
} -body {
set client [socket -async localhost $port]
fileevent $client writable {
lappend x [fconfigure $client -error]
fileevent $client writable {}
}
set after [after $latency {lappend x timeout}]
while {[llength $x] < 2 && "timeout" ni $x} {
vwait x
}
lsort $x; # we only want to see both events, the order doesn't matter
} -cleanup {
after cancel $after
close $server
close $client
unset x
} -result {{} ok}
test socket-14.2 {[socket -async] fileevent connection refused} \
-constraints {socket} \
-body {
set client [socket -async localhost [randport]]
fileevent $client writable {set x ok}
set after [after $latency {set x timeout}]
vwait x
after cancel $after
lappend x [fconfigure $client -error]
} -cleanup {
after cancel $after
close $client
unset x after client
} -result {ok {connection refused}}
test socket-14.3 {[socket -async] when server only listens on IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
-setup {
proc accept {s a p} {
global x
puts $s bye
close $s
set x ok
}
set server [socket -server accept -myaddr ::1 0]
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set client [socket -async localhost $port]
set after [after $latency {set x [fconfigure $client -error]}]
vwait x
set x
} -cleanup {
after cancel $after
close $server
close $client
unset x
} -result ok
test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
-constraints {socket} \
-setup {
proc accept {s a p} {
puts $s bye
close $s
}
set server [socket -server accept -myaddr localhost 0]
set port [lindex [fconfigure $server -sockname] 2]
set x ""
} -body {
set client [socket -async localhost $port]
fileevent $client writable {
lappend x [fconfigure $client -error]
fileevent $client writable {}
}
fileevent $client readable {lappend x [gets $client]}
set after [after $latency {lappend x timeout}]
while {[llength $x] < 2 && "timeout" ni $x} {
vwait x
}
lsort $x
} -cleanup {
after cancel $after
close $client
close $server
unset x
} -result {{} bye}
# FIXME: we should also have an IPv6 counterpart of this
test socket-14.5 {[socket -async] which fails before any connect() can be made} \
-constraints {socket supported_inet notWine} \
-body {
# address from rfc5737
socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
} \
-returnCodes 1 \
-result {couldn't open socket: cannot assign requested address}
test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \
-constraints {socket supported_inet localhost_v4} \
-setup {
proc accept {s a p} {
global x
puts $s bye
close $s
set x ok
}
set server [socket -server accept -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $server -sockname] 2]
set x ""
} \
-body {
set client [socket -async localhost $port]
for {set i 0} {$i < 50} {incr i } {
update
if {$x ne ""} {
lappend x [gets $client]
break
}
after 100
}
set x
} \
-cleanup {
close $server
close $client
unset x
} \
-result {ok bye}
test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
-setup {
proc accept {s a p} {
global x
puts $s bye
close $s
set x ok
}
set server [socket -server accept -myaddr ::1 0]
set port [lindex [fconfigure $server -sockname] 2]
set x ""
} \
-body {
set client [socket -async localhost $port]
for {set i 0} {$i < 50} {incr i } {
update
if {$x ne ""} {
lappend x [gets $client]
break
}
after 100
}
set x
} \
-cleanup {
close $server
close $client
unset x
} \
-result {ok bye}
test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \
-constraints {socket supported_inet localhost_v4} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr 127.0.0.1 0]
proc accept {s h p} {puts $s ok; close $s; set ::x 1}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
} -cleanup {
close $fd
close $sock
removeFile script
} -result {{} ok {}}
test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr ::1 0]
proc accept {s h p} {puts $s ok; close $s; set ::x 1}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
} -cleanup {
close $fd
close $sock
removeFile script
} -result {{} ok {}}
test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \
-constraints {socket} \
-body {
set sock [socket -async localhost [randport]]
catch {gets $sock} x
list $x [fconfigure $sock -error] [fconfigure $sock -error]
} -cleanup {
close $sock
} -match glob -result {{error reading "sock*": transport endpoint is not connected} {connection refused} {}}
test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \
-constraints {socket supported_inet localhost_v4} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr 127.0.0.1 0]
proc accept {s h p} {puts $s ok; close $s; set ::x 1}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
fconfigure $sock -blocking 0
for {set i 0} {$i < 50} {incr i } {
if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
after 200
}
set x
} -cleanup {
close $fd
close $sock
removeFile script
} -result {ok}
test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr ::1 0]
proc accept {s h p} {puts $s ok; close $s; set ::x 1}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
fconfigure $sock -blocking 0
for {set i 0} {$i < 50} {incr i } {
if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
after 200
}
set x
} -cleanup {
close $fd
close $sock
removeFile script
} -result {ok}
test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \
-constraints {socket} \
-body {
set sock [socket -async localhost [randport]]
fconfigure $sock -blocking 0
for {set i 0} {$i < 50} {incr i } {
if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
after 200
}
list $x [fconfigure $sock -error] [fconfigure $sock -error]
} -cleanup {
close $sock
} -match glob -result {{error reading "sock*": transport endpoint is not connected} {connection refused} {}}
test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \
-constraints {socket supported_inet localhost_v4} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr 127.0.0.1 0]
proc accept {s h p} {set ::x $s}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
puts [gets $x]
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
puts $sock ok
flush $sock
list [fconfigure $sock -error] [gets $fd]
} -cleanup {
close $fd
close $sock
removeFile script
} -result {{} ok}
test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr ::1 0]
proc accept {s h p} {set ::x $s}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
puts [gets $x]
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
puts $sock ok
flush $sock
list [fconfigure $sock -error] [gets $fd]
} -cleanup {
close $fd
close $sock
removeFile script
} -result {{} ok}
test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \
-constraints {socket supported_inet localhost_v4} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr 127.0.0.1 0]
proc accept {s h p} {set ::x $s}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
puts [gets $x]
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
fconfigure $sock -blocking 0
puts $sock ok
flush $sock
fileevent $fd readable {set x 1}
vwait x
list [fconfigure $sock -error] [gets $fd]
} -cleanup {
close $fd
close $sock
removeFile script
} -result {{} ok}
test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
-setup {
makeFile {
fileevent stdin readable exit
set server [socket -server accept -myaddr ::1 0]
proc accept {s h p} {set ::x $s}
puts [lindex [fconfigure $server -sockname] 2]
flush stdout
vwait x
puts [gets $x]
} script
set fd [open |[list [interpreter] script] RDWR]
set port [gets $fd]
} -body {
set sock [socket -async localhost $port]
fconfigure $sock -blocking 0
puts $sock ok
flush $sock
fileevent $fd readable {set x 1}
vwait x
list [fconfigure $sock -error] [gets $fd]
} -cleanup {
close $fd
close $sock
removeFile script
} -result {{} ok}
test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
-constraints {socket notWinCI} \
-body {
set sock [socket -async localhost [randport]]
fconfigure $sock -blocking 0
puts $sock ok
fileevent $sock writable {set x 1}
vwait x
close $sock
} -cleanup {
catch {close $sock}
unset x
} -result {transport endpoint is not connected} -returnCodes 1
test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \
-constraints {socket testsocket_testflags} \
-body {
set sock [socket -async localhost [randport]]
# Set the socket in async test mode.
# The async connect will not be continued on the following fconfigure
# and puts/flush. Thus, the connect will fail after them.
testsocket testflags $sock 1
fconfigure $sock -blocking 0
puts $sock ok
flush $sock
testsocket testflags $sock 0
fileevent $sock writable {set x 1}
vwait x
close $sock
} -cleanup {
catch {close $sock}
catch {unset x}
} -result {transport endpoint is not connected} -returnCodes 1
test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \
-constraints {socket} \
-body {
set s [socket -async localhost [randport]]
for {set i 0} {$i < 50} {incr i} {
set x [fconfigure $s -error]
if {$x != ""} break
after 200
}
set x
} -cleanup {
close $s
unset x s
} -result {connection refused}
test socket-14.13 {testing writable event when quick failure} \
-constraints {socket win supported_inet notWine} \
-body {
# Test for bug 336441ed59 where a quick background fail was ignored
|
| ︙ | ︙ | |||
2473 2474 2475 2476 2477 2478 2479 |
} -cleanup {
catch {close $s}
after cancel $a1
} -result readable
test socket-14.15 {blocking read on async socket should not trigger event handlers} \
-constraints socket -body {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 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 |
} -cleanup {
catch {close $s}
after cancel $a1
} -result readable
test socket-14.15 {blocking read on async socket should not trigger event handlers} \
-constraints socket -body {
set s [socket -async localhost [randport]]
set x ok
fileevent $s writable {set x fail}
catch {read $s}
close $s
set x
} -result ok
# v4 and v6 is required to prevent that the async connect does not terminate
# before the fconfigure command. There is always an additional ip to try.
test socket-14.16 {empty -peername while [socket -async] connecting} \
-constraints {socket localhost_v4 localhost_v6} \
-body {
set client [socket -async localhost [randport]]
fconfigure $client -peername
} -cleanup {
catch {close $client}
} -result {}
# v4 and v6 is required to prevent that the async connect does not terminate
# before the fconfigure command. There is always an additional ip to try.
test socket-14.17 {empty -sockname while [socket -async] connecting} \
-constraints {socket localhost_v4 localhost_v6} \
-body {
set client [socket -async localhost [randport]]
fconfigure $client -sockname
} -cleanup {
catch {close $client}
} -result {}
# test for bug c6ed4acfd8: running async socket connect with other connect
# established will block tcl as it goes in an infinite loop in vwait
test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \
-constraints {socket} \
-body {
proc accept {channel address port} {}
set port [randport]
set ssock [socket -server accept $port]
set csock1 [socket -async localhost [randport]]
set csock2 [socket localhost $port]
after 1000 {set done ok}
vwait done
} -cleanup {
catch {close $ssock}
catch {close $csock1}
catch {close $csock2}
} -result {}
test socket-14.19 {tip 456 -- introduce the -reuseport option} \
-constraints {socket notWine} \
-body {
proc accept {channel address port} {}
set port [randport]
set ssock1 [socket -server accept -reuseport yes $port]
set ssock2 [socket -server accept -reuseport yes $port]
return ok
} -cleanup {
catch {close $ssock1}
catch {close $ssock2}
} -result ok
set num 0
set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}}
set resultok {-result "sock*" -match glob}
set resulterr {
-result {couldn't open socket: connection refused}
-returnCodes 1
}
foreach {servip sc} $x {
foreach {cliip cc} $x {
set constraints socket
lappend constraints $sc $cc
set result $resulterr
switch -- [lsort -unique [list $servip $cliip]] {
localhost - 127.0.0.1 - ::1 {
set result $resultok
}
{127.0.0.1 localhost} {
if {[testConstraint localhost_v4]} {
set result $resultok
}
}
{::1 localhost} {
if {[testConstraint localhost_v6]} {
set result $resultok
}
}
}
test socket-15.1.$num "Connect to $servip from $cliip" \
-constraints $constraints -setup {
set server [socket -server accept -myaddr $servip 0]
proc accept {s h p} { close $s }
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set s [socket $cliip $port]
} -cleanup {
close $server
catch {close $s}
} {*}$result
incr num
}
}
test socket-bug-31fc36fe47 "Crash listening in multiple threads" \
-constraints thread -body {
close [socket -server xxx 0]
set tid [thread::create]
thread::send $tid {close [socket -server accept 0]}
thread::release $tid
} -result 0
::tcltest::cleanupTests
flush stdout
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/source.test.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
source $sourcefile
} -cleanup {
removeFile source.file
} -result {a b c d e f}
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
| | | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
source $sourcefile
} -cleanup {
removeFile source.file
} -result {a b c d e f}
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
}
foreach e $expected a $actual {
if {![string match $e $a]} {
return 0
}
}
return 1
}
customMatch listGlob [namespace which ListGlobMatch]
test source-2.3 {source error conditions} -setup {
set sourcefile [makeFile {
|
| ︙ | ︙ |
Changes to tests/split.test.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
split {}
} {}
test split-1.7 {basic split commands} {
split { }
} {{} {} {} {}}
test split-1.8 {basic split commands} {
proc foo {} {
| | | | | | | | | | 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 |
split {}
} {}
test split-1.7 {basic split commands} {
split { }
} {{} {} {} {}}
test split-1.8 {basic split commands} {
proc foo {} {
set x {}
foreach f [split {]\n} {}] {
append x $f
}
return $x
}
foo
} {]\n}
test split-1.9 {basic split commands} {
proc foo {} {
set x ab\x00c
set y [split $x {}]
return $y
}
foo
} "a b \x00 c"
test split-1.10 {basic split commands} {
split "a0ab1b2bbb3\x00c4" ab\x00c
} {{} 0 {} 1 2 {} {} 3 {} 4}
test split-1.11 {basic split commands} {
|
| ︙ | ︙ |
Changes to tests/string.test.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
| | | | | | | | | | | 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 |
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
return [lindex $lines 3 3]
}
proc leaktest {script {iterations 3}} {
set end [getbytes]
for {set i 0} {$i < $iterations} {incr i} {
uplevel 1 $script
set tmp $end
set end [getbytes]
}
return [expr {$end - $tmp}]
}
}
proc representationpoke s {
set r [::tcl::unsupported::representation $s]
list [lindex $r 3] [string match {*, string representation "*"} $r]
}
|
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
test string-1.2.$noComp {error conditions} {
list [catch {run {string}} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
test stringComp-1.3.$noComp {error condition - undefined method during compile} {
# We don't want this to complain about 'never' because it may never
# be called, or string may get redefined. This must compile OK.
proc foo {str i} {
| | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
test string-1.2.$noComp {error conditions} {
list [catch {run {string}} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
test stringComp-1.3.$noComp {error condition - undefined method during compile} {
# We don't want this to complain about 'never' because it may never
# be called, or string may get redefined. This must compile OK.
proc foo {str i} {
if {"yes" == "no"} { string never called but complains here }
string index $str $i
}
foo abc 0
} a
test string-2.1.$noComp {string compare, not enough args} {
list [catch {run {string compare a}} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
} 0
test string-2.35.$noComp {string compare, binary neq} {
run {string compare [binary format a100a 0 1] [binary format a100a 0 0]}
} 1
test string-2.36.$noComp {string compare, binary neq unequal length} {
run {string compare [binary format a20a 0 1] [binary format a100a 0 0]}
} 1
| | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
} 0
test string-2.35.$noComp {string compare, binary neq} {
run {string compare [binary format a100a 0 1] [binary format a100a 0 0]}
} 1
test string-2.36.$noComp {string compare, binary neq unequal length} {
run {string compare [binary format a20a 0 1] [binary format a100a 0 0]}
} 1
test string-2.37.$noComp {string compare, big -length} {
if {[package vsatisfies [info patchlevel] 8.7-]} {
run {string compare -length 0x100000000 ab abde}
} else {
run {string compare -length 0x7fffffff ab abde}
}
} -1
test string-2.38a.$noComp {string compare empty string against byte array} {
# Bug edb4b065f4
run {string compare "" [binary decode hex 00]}
} -1
test string-2.38b.$noComp {string compare -length empty string against byte array} {
# Bug edb4b065f4
run {string compare -length 1 "" [binary decode hex 00]}
} -1
test string-2.38c.$noComp {string compare -nocase empty string against byte array} {
# Bug edb4b065f4
run {string compare -nocase "" [binary decode hex 00]}
} -1
test string-2.38d.$noComp {string compare empty string against byte array} {
# Bug edb4b065f4
run {string compare [binary decode hex 00] ""}
} 1
test string-2.38e.$noComp {string compare -length empty string against byte array} {
# Bug edb4b065f4
run {string compare -length 1 [binary decode hex 00] ""}
} 1
test string-2.38f.$noComp {string compare -nocase empty string against byte array} {
# Bug edb4b065f4
run {string compare -nocase [binary decode hex 00] ""}
} 1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
test string-3.1.$noComp {string equal} {
run {string equal abcde abdef}
} 0
test string-3.2.$noComp {string equal} {
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 |
test string-3.41.$noComp {string equal, binary neq} {
run {string equal [binary format a100a 0 1] [binary format a100a 0 0]}
} 0
test string-3.42.$noComp {string equal, binary neq inequal length} {
run {string equal [binary format a20a 0 1] [binary format a100a 0 0]}
} 0
test string-3.43.$noComp {string equal, big -length} {
| > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
test string-3.41.$noComp {string equal, binary neq} {
run {string equal [binary format a100a 0 1] [binary format a100a 0 0]}
} 0
test string-3.42.$noComp {string equal, binary neq inequal length} {
run {string equal [binary format a20a 0 1] [binary format a100a 0 0]}
} 0
test string-3.43.$noComp {string equal, big -length} {
if {[package vsatisfies [info patchlevel] 8.7-]} {
run {string equal -length 0x100000000 abc def}
} else {
run {string equal -length 0x7fffffff abc def}
}
} 0
test string-3.44.$noComp {string equal, bigger -length} -body {
run {string equal -length 18446744073709551616 abc def}
} -returnCodes 1 -result {integer value too large to represent}
test string-3.45a.$noComp {string equal empty string against byte array} {
# Bug edb4b065f4
run {string equal "" [binary decode hex 00]}
} 0
test string-3.45b.$noComp {string equal -length empty string against byte array} {
# Bug edb4b065f4
run {string equal -length 1 "" [binary decode hex 00]}
} 0
test string-3.45c.$noComp {string equal -nocase empty string against byte array} {
# Bug edb4b065f4
run {string equal -nocase "" [binary decode hex 00]}
} 0
test string-3.45d.$noComp {string equal empty string against byte array} {
# Bug edb4b065f4
run {string equal [binary decode hex 00] ""}
} 0
test string-3.45e.$noComp {string equal -length empty string against byte array} {
# Bug edb4b065f4
run {string equal -length 1 [binary decode hex 00] ""}
} 0
test string-3.45f.$noComp {string equal -nocase empty string against byte array} {
# Bug edb4b065f4
run {string equal -nocase [binary decode hex 00] ""}
} 0
test string-4.1.$noComp {string first, not enough args} {
list [catch {run {string first a}} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test string-4.2.$noComp {string first, bad args} {
list [catch {run {string first a b c}} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
} {0 1 1 1 0 0}
test string-11.55.$noComp {string match, invalid binary optimization} {
[format string] match \u0141 [binary format c 65]
} 0
test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} {
apply {s {
| | | 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 |
} {0 1 1 1 0 0}
test string-11.55.$noComp {string match, invalid binary optimization} {
[format string] match \u0141 [binary format c 65]
} 0
test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} {
apply {s {
string range $s 0 end-5
}} 12345
} {}
test string-12.1.$noComp {string range} {
list [catch {run {string range}} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
test string-12.2.$noComp {string range} {
list [catch {run {string range a 1}} msg] $msg
|
| ︙ | ︙ | |||
1632 1633 1634 1635 1636 1637 1638 |
test string-14.24.$noComp {string replace \xC0 \x80} testbytestring {
run {string length [string replace ?[testbytestring \x80] 0 end-1 [testbytestring \xC0]]}
} 2
test stringComp-14.21.$noComp {Bug 82e7f67325} {
apply {x {
| | | | | | | | | | | | | | | | | | | | 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 |
test string-14.24.$noComp {string replace \xC0 \x80} testbytestring {
run {string length [string replace ?[testbytestring \x80] 0 end-1 [testbytestring \xC0]]}
} 2
test stringComp-14.21.$noComp {Bug 82e7f67325} {
apply {x {
set a [join $x {}]
lappend b [string length [string replace ___! 0 2 $a]]
lappend b [string length [string replace ___! 0 2 $a[unset a]]]
}} {a b}
} {3 3}
test stringComp-14.22.$noComp {Bug 82e7f67325} memory {
# As in stringComp-14.1, but make sure we don't retain too many refs
leaktest {
apply {x {
set a [join $x {}]
lappend b [string length [string replace ___! 0 2 $a]]
lappend b [string length [string replace ___! 0 2 $a[unset a]]]
}} {a b}
}
} {0}
test stringComp-14.23.$noComp {Bug 0dca3bfa8f} {
apply {arg {
set argCopy $arg
set arg [string replace $arg 1 2 aa]
# Crashes in comparison before fix
expr {$arg ne $argCopy}
}} abcde
} 1
test stringComp-14.24.$noComp {Bug 1af8de570511} {
apply {{x y} {
# Generate an unshared string value
set val ""
for { set i 0 } { $i < $x } { incr i } {
set val [format "0%s" $val]
}
string replace $val[unset val] 1 1 $y
}} 4 x
} 0x00
test stringComp-14.25.$noComp {} {
string length [string replace [string repeat a\xFE 2] 3 end {}]
} 3
test stringComp-14.26.$noComp {} {
run {string replace abcd 0x10000000000000000-0xffffffffffffffff 2 e}
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 |
set x 5
catch {testindexobj $x foo bar soom}
run {string is boolean $x}
} 0
test string-23.1.$noComp {string is command with empty string} {
set s ""
list \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set x 5
catch {testindexobj $x foo bar soom}
run {string is boolean $x}
} 0
test string-23.1.$noComp {string is command with empty string} {
set s ""
list \
[run {string is alnum $s}] \
[run {string is alpha $s}] \
[run {string is ascii $s}] \
[run {string is control $s}] \
[run {string is boolean $s}] \
[run {string is digit $s}] \
[run {string is double $s}] \
[run {string is false $s}] \
[run {string is graph $s}] \
[run {string is integer $s}] \
[run {string is lower $s}] \
[run {string is print $s}] \
[run {string is punct $s}] \
[run {string is space $s}] \
[run {string is true $s}] \
[run {string is upper $s}] \
[run {string is wordchar $s}] \
[run {string is xdigit $s}] \
} {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1}
test string-23.2.$noComp {string is command with empty string} {
set s ""
list \
[run {string is alnum -strict $s}] \
[run {string is alpha -strict $s}] \
[run {string is ascii -strict $s}] \
[run {string is control -strict $s}] \
[run {string is boolean -strict $s}] \
[run {string is digit -strict $s}] \
[run {string is double -strict $s}] \
[run {string is false -strict $s}] \
[run {string is graph -strict $s}] \
[run {string is integer -strict $s}] \
[run {string is lower -strict $s}] \
[run {string is print -strict $s}] \
[run {string is punct -strict $s}] \
[run {string is space -strict $s}] \
[run {string is true -strict $s}] \
[run {string is upper -strict $s}] \
[run {string is wordchar -strict $s}] \
[run {string is xdigit -strict $s}] \
} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}
test string-24.1.$noComp {string reverse command} -body {
run {string reverse}
} -returnCodes error -result "wrong # args: should be \"string reverse string\""
test string-24.2.$noComp {string reverse command} -body {
|
| ︙ | ︙ | |||
2209 2210 2211 2212 2213 2214 2215 |
tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
test string-26.10.$noComp {tcl::prefix} -body {
tcl::prefix match -error {-level 1} {apa bepa bear depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
test string-26.10.1.$noComp {tcl::prefix} -setup {
proc _testprefix {args} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 |
tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
test string-26.10.$noComp {tcl::prefix} -body {
tcl::prefix match -error {-level 1} {apa bepa bear depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
test string-26.10.1.$noComp {tcl::prefix} -setup {
proc _testprefix {args} {
array set opts {-a x -b y -c y}
foreach {opt val} $args {
set opt [tcl::prefix match -error {-level 1} {-a -b -c} $opt]
set opts($opt) $val
}
array get opts
}
} -body {
set a [catch {_testprefix -x u} result options]
dict get $options -errorinfo
} -cleanup {
rename _testprefix {}
} -result {bad option "-x": must be -a, -b, or -c
while executing
"_testprefix -x u"}
# Helper for memory stress tests
# Repeat each body in a local space checking that memory does not increase
proc MemStress {args} {
set res {}
foreach body $args {
set end 0
for {set i 0} {$i < 5} {incr i} {
proc MemStress_Body {} $body
uplevel 1 MemStress_Body
rename MemStress_Body {}
set tmp $end
set end [lindex [lindex [split [memory info] "\n"] 3] 3]
}
lappend res [expr {$end - $tmp}]
}
return $res
}
test string-26.11.$noComp {tcl::prefix: testing for leaks} -body {
# This test is made to stress object reference management
MemStress {
set table {hejj miff gurk}
set item [lindex $table 1]
# If not careful, this can cause a circular reference
# that will cause a leak.
tcl::prefix match $table $item
} {
# A similar case with nested lists
set table2 {hejj {miff maff} gurk}
set item [lindex [lindex $table2 1] 0]
tcl::prefix match $table2 $item
} {
# A similar case with dict
set table3 {hejj {miff maff} gurk2}
set item [lindex [dict keys [lindex $table3 1]] 0]
tcl::prefix match $table3 $item
}
} -constraints memory -result {0 0 0}
test string-26.12.$noComp {tcl::prefix: testing for leaks} -body {
# This is a memory leak test in a form that might actually happen
# in real code. The shared literal "miff" causes a connection
# between the item and the table.
MemStress {
proc stress1 {item} {
set table [list hejj miff gurk]
tcl::prefix match $table $item
}
proc stress2 {} {
stress1 miff
}
stress2
rename stress1 {}
rename stress2 {}
}
} -constraints memory -result 0
test string-26.13.$noComp {tcl::prefix: testing for leaks} -body {
# This test is made to stress object reference management
MemStress {
set table [list hejj miff]
set item $table
set error $table
# Use the same objects in all places
catch {
tcl::prefix match -error $error $table $item
}
}
} -constraints memory -result {0}
test string-27.1.$noComp {tcl::prefix all, not enough args} -body {
tcl::prefix all a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
test string-27.2.$noComp {tcl::prefix all, bad args} -body {
|
| ︙ | ︙ | |||
2493 2494 2495 2496 2497 2498 2499 |
run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]}
} 0123_
test string-31.15.$noComp {string insert, pure byte array, neither shared} {
run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
} 01_23
test string-31.16.$noComp {string insert, pure byte array, first shared} {
run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
| | | | | | 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 |
run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]}
} 0123_
test string-31.15.$noComp {string insert, pure byte array, neither shared} {
run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
} 01_23
test string-31.16.$noComp {string insert, pure byte array, first shared} {
run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
[makeByteArray _]}
} 01_23
test string-31.17.$noComp {string insert, pure byte array, second shared} {
run {tcl::string::insert [makeByteArray 0123] 2\
[makeShared [makeByteArray _]]}
} 01_23
test string-31.18.$noComp {string insert, pure byte array, both shared} {
run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
[makeShared [makeByteArray _]]}
} 01_23
test string-31.19.$noComp {string insert, start of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]}
} _0123
test string-31.20.$noComp {string insert, middle of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]}
} 01_23
test string-31.21.$noComp {string insert, end of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]}
} 0123_
test string-31.22.$noComp {string insert, str start, pure Uni, first shared} {
run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]}
} _0123
test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} {
run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]}
} 01_23
test string-31.24.$noComp {string insert, string end, pure Uni, both shared} {
run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\
[makeShared [makeUnicode _]]}
} 0123_
test string-31.25.$noComp {string insert, neither byte array nor Unicode} {
run {tcl::string::insert [makeList a b c] 1 zzzzzz}
} {azzzzzz b c}
test string-31.26.$noComp {[11229bad5f] string insert, compiler} -setup {
set i 2
} -body {
|
| ︙ | ︙ |
Changes to tests/stringObj.test.
| ︙ | ︙ | |||
162 163 164 165 166 167 168 |
} {11 17 ab34567890x}
test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
list [teststringobj length2 1] [teststringobj get 1]
} {0 {}}
| | | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
} {11 17 ab34567890x}
test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
list [teststringobj length2 1] [teststringobj get 1]
} {0 {}}
test stringObj-6.9 {Tcl_AppendStringsToObj, pure unicode} testobj {
testobj freeallvars
teststringobj set2 1 [string replace abc 1 1 d]
teststringobj appendstrings 1 foo bar soom
teststringobj get 1
} adcfoobarsoom
test stringObj-7.1 {SetStringFromAny procedure} testobj {
|
| ︙ | ︙ |
Changes to tests/switch.test.
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
test switch-5.1 {errors in -regexp matching} -returnCodes error -body {
switch -regexp aaaab {
*b {subst glob}
aaaab {subst exact}
default {subst none}
}
| | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
test switch-5.1 {errors in -regexp matching} -returnCodes error -body {
switch -regexp aaaab {
*b {subst glob}
aaaab {subst exact}
default {subst none}
}
} -result {cannot compile regular expression pattern: invalid quantifier operand}
test switch-6.1 {backslashes in patterns} {
switch -exact {\a\$\.\[} {
\a\$\.\[ {subst first}
\a\\$\.\\[ {subst second}
\\a\\$\\.\\[ {subst third}
{\a\\$\.\\[} {subst fourth}
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
c {}
}
} -returnCodes error -result {invalid command name "-foo"}
test switch-8.1 {empty body} {
set msg {}
switch {2} {
| | | | | | | 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 |
c {}
}
} -returnCodes error -result {invalid command name "-foo"}
test switch-8.1 {empty body} {
set msg {}
switch {2} {
1 {set msg 1}
2 {}
default {set msg 2}
}
} {}
proc test_switch_body {} {
return "INVOKED"
}
test switch-8.2 {weird body text, variable} {
set cmd {test_switch_body}
switch Foo {
Foo $cmd
}
} {INVOKED}
test switch-8.3 {weird body text, variable} {
set cmd {test_switch_body}
switch Foo {
Foo {$cmd}
}
} {INVOKED}
test switch-9.1 {empty pattern/body list} -returnCodes error -body {
switch x
} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"}
test switch-9.2 {unpaired pattern} -returnCodes error -body {
|
| ︙ | ︙ |
Changes to tests/tcltest.test.
| ︙ | ︙ | |||
349 350 351 352 353 354 355 |
::tcltest::PrintError "a really short string"
::tcltest::PrintError "a really really really really really really long \
string containing \"quotes\" and other bad bad stuff"
::tcltest::PrintError "a really really long string containing a \
\"Path/that/is/really/long/and/contains/no/spaces\""
::tcltest::PrintError "a really really long string containing a \
\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
| | | 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 |
::tcltest::PrintError "a really short string"
::tcltest::PrintError "a really really really really really really long \
string containing \"quotes\" and other bad bad stuff"
::tcltest::PrintError "a really really long string containing a \
\"Path/that/is/really/long/and/contains/no/spaces\""
::tcltest::PrintError "a really really long string containing a \
\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl9.0/win32-ix86/tests/core\" to \"Z:/ws/tcl9.0/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
-constraints unixOrWin
-body {
child msg $printerror
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
set f2 [pwd]
set f3 [workingDirectory $current]
set f4 [pwd]
set f5 [workingDirectory]
list $f1 $f2 $f3 $f4 $f5
}
-result "[list $normaldirectory \
| | | | | | 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 |
set f2 [pwd]
set f3 [workingDirectory $current]
set f4 [pwd]
set f5 [workingDirectory]
list $f1 $f2 $f3 $f4 $f5
}
-result "[list $normaldirectory \
$normaldirectory \
$current \
$current \
$current]"
-cleanup {
set ::tcltest::workingDirectory $old
cd $current
}
}
# clean up from directory testing
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
-body {list a b c d e} \
-result {[ab] b c d e} \
-match glob
test tcltest-21.8 {force a test command failure} \
-setup {set fail $::tcltest::currentFailure} \
-body {
| | | | | 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 |
-body {list a b c d e} \
-result {[ab] b c d e} \
-match glob
test tcltest-21.8 {force a test command failure} \
-setup {set fail $::tcltest::currentFailure} \
-body {
test tcltest-21.8.0 {
return 2
} {1}
} \
-returnCodes 1 \
-cleanup {set ::tcltest::currentFailure $fail} \
-result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
test tcltest-21.9 {test command with setup} \
-setup {set foo 1} \
|
| ︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 |
}
# customMatch
proc matchNegative { expected actual } {
set match 0
foreach a $actual e $expected {
if { $a != $e } {
| | | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 |
}
# customMatch
proc matchNegative { expected actual } {
set match 0
foreach a $actual e $expected {
if { $a != $e } {
set match 1
break
}
}
return $match
}
test tcltest-24.0 {
customMatch: syntax
|
| ︙ | ︙ |
Changes to tests/tcltests.tcl.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
testConstraint purify [tcl::build-info purify]
testConstraint debugpurify [
expr {
![tcl::build-info memdebug]
&& [testConstraint debug]
&& [testConstraint purify]
}]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
testConstraint thread [expr {![catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
namespace eval ::tcltests {
| > > > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
testConstraint purify [tcl::build-info purify]
testConstraint debugpurify [
expr {
![tcl::build-info memdebug]
&& [testConstraint debug]
&& [testConstraint purify]
}]
testConstraint bigmem [expr {[
info exists ::env(TCL_TESTCONSTRAINT_BIGMEM)]
? !!$::env(TCL_TESTCONSTRAINT_BIGMEM)
: 1
}]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
testConstraint thread [expr {![catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
namespace eval ::tcltests {
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
# Expected result is as generated by Tcl_WrongNumArgs
# Only works if optional arguments come after fixed arguments
# E.g.
# testnumargs "zipfs mount" "" "?mountpoint? ?zipfile? ?password?"
# testnumargs "lappend" "varName" "?value ...?"
proc testnumargs {cmd {fixed {}} {optional {}} args} {
variable count
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# Expected result is as generated by Tcl_WrongNumArgs
# Only works if optional arguments come after fixed arguments
# E.g.
# testnumargs "zipfs mount" "" "?mountpoint? ?zipfile? ?password?"
# testnumargs "lappend" "varName" "?value ...?"
proc testnumargs {cmd {fixed {}} {optional {}} args} {
variable count
set minargs [llength $fixed]
set maxargs [expr {$minargs + [llength $optional]}]
if {[regexp {\.\.\.\??$} [lindex $optional end]]} {
unset maxargs; # No upper limit on num of args
}
set message "wrong # args: should be \"$cmd"
if {[llength $fixed]} {
append message " $fixed"
}
if {[llength $optional]} {
append message " $optional"
}
if {[llength $fixed] == 0 && [llength $optional] == 0} {
append message " \""
} else {
append message "\""
}
set label [join $cmd -]
if {$minargs > 0} {
set arguments [lrepeat [expr {$minargs-1}] x]
test $label-minargs-[incr count($label-minargs)] \
"$label no arguments" \
-body "$cmd" \
-result $message -returnCodes error \
{*}$args
if {$minargs > 1} {
test $label-minargs-[incr count($label-minargs)] \
"$label missing arguments" \
-body "$cmd $arguments" \
-result $message -returnCodes error \
{*}$args
}
}
if {[info exists maxargs]} {
set arguments [lrepeat [expr {$maxargs+1}] x]
test $label-maxargs-[incr count($label-maxargs)] \
"$label extra arguments" \
-body "$cmd $arguments" \
-result $message -returnCodes error \
{*}$args
}
}
init
package provide tcltests 0.1
}
|
Changes to tests/thread.test.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
thread::release
}
proc getThreadErrorFromInfo { info } {
set list [split $info \n]
set idx [lsearch -glob $list "*eval*unwound*"]
if {$idx >= 0} then {
| | | | | | | | | | | 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 |
thread::release
}
proc getThreadErrorFromInfo { info } {
set list [split $info \n]
set idx [lsearch -glob $list "*eval*unwound*"]
if {$idx >= 0} then {
return [lindex $list $idx]
}
set idx [lsearch -glob $list "*eval*canceled*"]
if {$idx >= 0} then {
return [lindex $list $idx]
}
return ""; # some other error we do not care about.
}
proc findThreadError { info } {
foreach error [lreverse $info] {
set error [getThreadErrorFromInfo $error]
if {[string length $error] > 0} then {
return $error
}
}
return ""; # some other error we do not care about.
}
proc ThreadError {id info} {
global threadSawError
if {[string length [getThreadErrorFromInfo $info]] > 0} then {
global threadId threadError
set threadId $id
lappend threadError($id) $info
}
set threadSawError($id) true; # signal main thread to exit [vwait].
}
proc threadSuperKill id {
variable threadSuperKillScript
try {
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
set numthreads [llength [thread::names]]
thread::release -wait $serverthread
set numthreads
} 2
test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
thread::create {set x 5}
foreach try {0 1 2 4 5 6} {
| | | | | | | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
set numthreads [llength [thread::names]]
thread::release -wait $serverthread
set numthreads
} 2
test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
thread::create {set x 5}
foreach try {0 1 2 4 5 6} {
# Try various ways to yield
update
after 10
set l [llength [thread::names]]
if {$l == 1} {
break
}
}
set l
} 1
test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
thread::create {{*}{}}
update
after 10
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.5 {cancel: pure inside-command loop} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.8 {cancel: pure bytecode loop custom result} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
403 404 405 406 407 408 409 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread "the eval was canceled"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread "the eval was canceled"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was canceled}}
test thread-7.9 {cancel: pure inside-command loop custom result} -constraints {
thread
drainEventQueue
} -setup {
|
| ︙ | ︙ | |||
438 439 440 441 442 443 444 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread "the eval was canceled"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread "the eval was canceled"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was canceled}}
test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints {
thread
drainEventQueue
} -setup {
|
| ︙ | ︙ | |||
472 473 474 475 476 477 478 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread "the eval was unwound"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread "the eval was unwound"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was unwound}}
test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints {
thread
drainEventQueue
} -setup {
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread "the eval was unwound"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread "the eval was unwound"]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was unwound}}
test thread-7.12 {cancel: after} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.13 {cancel: after -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.15 {cancel: vwait -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.17 {cancel: expr -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
672 673 674 675 676 677 678 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.18 {cancel: expr bignum} {thread drainEventQueue knownBug} {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
set foo 1
}
#
# BUGBUG: This will not cancel because libtommath
# does not check Tcl_Canceled.
#
expr {2**99999}
}
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread); # WARNING: Never returns (see above).
thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above).
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 0 {}}
test thread-7.19 {cancel: expr bignum -unwind} {thread drainEventQueue knownBug} {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
set foo 1
}
#
# BUGBUG: This will not cancel because libtommath
# does not check Tcl_Canceled.
#
expr {2**99999}
}
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted; after 1000
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread); # WARNING: Never returns (see above).
thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above).
list $res [expr {[info exists ::threadIdStarted] ? \
$::threadIdStarted == $serverthread : 0}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 0 {}}
test thread-7.20 {cancel: subst} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
set i [interp create]
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
796 797 798 799 800 801 802 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
856 857 858 859 860 861 862 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainEventQueue} {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {interp cancel -- -unwind}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {interp cancel -- -unwind}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread drainEventQueue} {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
|
| ︙ | ︙ | |||
1201 1202 1203 1204 1205 1206 1207 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::cancel -unwind $serverthread]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {interp cancel -unwind}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {interp cancel -unwind}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
1326 1327 1328 1329 1330 1331 1332 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {interp cancel -unwind}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {interp cancel -unwind}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
1367 1368 1369 1370 1371 1372 1373 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
|
| ︙ | ︙ | |||
1410 1411 1412 1413 1414 1415 1416 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
| | | | | | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
}]]
# wait for other thread to signal "ready to cancel"
vwait ::threadIdStarted
set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
vwait ::threadSawError($serverthread)
thread::join $serverthread; drainEventQueue
list $res [expr {$::threadIdStarted == $serverthread}] \
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-8.1 {threaded fork stress} -constraints {thread} -setup {
unset -nocomplain ::threadCount ::execCount ::threads ::thread
set ::threadCount 10
|
| ︙ | ︙ |
Changes to tests/trace.test.
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.6 {trace array element reads} {
unset -nocomplain x
set info {}
trace add variable x read traceArray2
proc p {} {
| | | | | | | | | | | | 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 |
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.6 {trace array element reads} {
unset -nocomplain x
set info {}
trace add variable x read traceArray2
proc p {} {
global x
set x(2) willi
return $x(2)
}
list [catch {p} msg] $msg $info
} {0 willi {x 2 read}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
unset -nocomplain x
set info {}
trace add variable x read q
proc q {name1 name2 op} {
global info
set info [list $name1 $name2 $op]
global $name1
set ${name1}($name2) wolf
}
proc p {} {
global x
set x(X) willi
return $x(Y)
}
list [catch {p} msg] $msg $info
} {0 wolf {x Y read}}
test trace-1.8 {trace reads on whole arrays} {
unset -nocomplain x
set info {}
trace add variable x read traceArray
|
| ︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 |
} {{foo {set b 3} 0 3 leavestep}}
test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
trace add execution foo enter soom
proc ::soom args {lappend ::info SUCCESS [info level]}
set ::info {}
namespace eval test_ns_1 {
| | | | | | | | 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 |
} {{foo {set b 3} 0 3 leavestep}}
test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
trace add execution foo enter soom
proc ::soom args {lappend ::info SUCCESS [info level]}
set ::info {}
namespace eval test_ns_1 {
proc soom args {lappend ::info FAIL [info level]}
# [testevalobjv 1 ...] ought to produce the same
# results as [uplevel #0 ...].
testevalobjv 1 foo x
uplevel #0 foo x
}
namespace delete test_ns_1
trace remove execution foo enter soom
set ::info
} {SUCCESS 1 SUCCESS 1}
test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
trace add execution foo leave soom
proc ::soom args {lappend ::info SUCCESS [info level]}
set ::info {}
namespace eval test_ns_1 {
proc soom args {lappend ::info FAIL [info level]}
# [testevalobjv 1 ...] ought to produce the same
# results as [uplevel #0 ...].
testevalobjv 1 foo x
uplevel #0 foo x
}
namespace delete test_ns_1
trace remove execution foo leave soom
set ::info
} {SUCCESS 1 SUCCESS 1}
|
| ︙ | ︙ | |||
1691 1692 1693 1694 1695 1696 1697 |
set {*}$args
}
test trace-21.12 {bug 2438181} -setup {
trace add execution set2 leave {puts one two three #;}
} -body {
set2 a hello
| | | 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 |
set {*}$args
}
test trace-21.12 {bug 2438181} -setup {
trace add execution set2 leave {puts one two three #;}
} -body {
set2 a hello
} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channel? string"}
proc factorial {n} {
if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
return 1
}
test trace-22.1 {recursive(1) trace execution: enter} {
|
| ︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 |
list [catch {trace info command thisdoesntexist} res] $res
} {1 {unknown command "thisdoesntexist"}}
test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} {
catch {rename foo {}}
proc foo {} {
| | | | | | | 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 |
list [catch {trace info command thisdoesntexist} res] $res
} {1 {unknown command "thisdoesntexist"}}
test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} {
catch {rename foo {}}
proc foo {} {
set a 1
update idletasks
set b 1
}
set info {}
trace add execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
update
after idle {set a "idle"}
foo
trace remove execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
rename foo {}
unset -nocomplain a
join $info "\n"
} {foo foo enter
foo {set a 1} enterstep
foo {set a 1} 0 1 leavestep
foo {update idletasks} enterstep
|
| ︙ | ︙ | |||
2408 2409 2410 2411 2412 2413 2414 |
llength [trace info variable x]
} 0
test trace-34.1 {Bug 1201035} {
set ::x [list]
proc foo {} {lappend ::x foo}
proc bar args {
| | | | | | | | 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 |
llength [trace info variable x]
} 0
test trace-34.1 {Bug 1201035} {
set ::x [list]
proc foo {} {lappend ::x foo}
proc bar args {
lappend ::x $args
trace remove execution foo leavestep bar
trace remove execution foo enterstep bar
trace add execution foo leavestep bar
trace add execution foo enterstep bar
lappend ::x done
}
trace add execution foo leavestep bar
trace add execution foo enterstep bar
foo
set ::x
} {{{lappend ::x foo} enterstep} done foo}
|
| ︙ | ︙ | |||
2442 2443 2444 2445 2446 2447 2448 |
} {}
# We test here for the half-documented and currently valid interplay between
# delete traces and namespace deletion.
test trace-34.4 {Bug 1047286} {
variable x notrace
proc callback {old - -} {
| | | | | | | | | | | 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
} {}
# We test here for the half-documented and currently valid interplay between
# delete traces and namespace deletion.
test trace-34.4 {Bug 1047286} {
variable x notrace
proc callback {old - -} {
variable x "$old exists: [namespace which -command $old]"
}
namespace eval ::foo {proc bar {} {}}
trace add command ::foo::bar delete [namespace code callback]
namespace delete ::foo
set x
} {::foo::bar exists: ::foo::bar}
test trace-34.5 {Bug 1047286} {
variable x notrace
proc callback {old - -} {
variable x "$old exists: [namespace which -command $old]"
}
namespace eval ::foo {proc bar {} {}}
trace add command ::foo::bar delete [namespace code callback]
namespace eval ::foo namespace delete ::foo
set x
} {::foo::bar exists: }
test trace-34.6 {Bug 1458266} -setup {
proc dummy {} {}
proc stepTraceHandler {cmdString args} {
variable log
append log "[expr {[info level] - 1}]: [lindex [split $cmdString] 0]\n"
dummy
isTracedInside_2
}
proc cmdTraceHandler {cmdString args} {
# silent
}
proc isTracedInside_1 {} {
isTracedInside_2
}
proc isTracedInside_2 {} {
set x 2
}
} -body {
variable log {}
trace add execution isTracedInside_1 enterstep stepTraceHandler
trace add execution isTracedInside_2 enterstep stepTraceHandler
isTracedInside_1
variable first $log
|
| ︙ | ︙ |
Changes to tests/twapiTlsPlus.tcl.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 |
# Replacement for ::socket, use with http::register.
proc twapiTlsPlus::socket {args} {
variable socketCmd
set targ [lsearch -exact $args -type]
if {$targ != -1} {
| | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
# 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} {
|
| ︙ | ︙ |
Changes to tests/unixInit.test.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 99 100 101 102 |
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
set enc
} -cleanup {
unset -nocomplain env(LANG)
} -match regexp -result {^(iso8859-15?|utf-8)$}
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
catch {set oldlc_all $env(LC_ALL)}
catch {set oldtcl_library $env(TCL_LIBRARY)}
unset -nocomplain env(TCL_LIBRARY)
| > > > > > > > > > > > > > > > | | 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 |
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
set enc
} -cleanup {
unset -nocomplain env(LANG)
} -match regexp -result {^(iso8859-15?|utf-8)$}
# unixInit-3.2 depends on the *spawned* [interpreter] being able to locate
# tcl_library without setting of TCL_LIBRARY env. This in turn depends on
# Tcl's "library" directory being under the parent or grandparent of the
# executable directory (the initScript search path in tclInterp.c).
# Thus this constraint. On GiuHub CI, the only time this is not true
# is for the XCode builds.
if {[string match [zipfs root]* [info library]] ||
[file isfile [file normalize [file join [info nameofexecutable] .. .. library init.tcl]]] ||
[file isfile [file normalize [file join [info nameofexecutable] .. .. .. library init.tcl]]]
} {
tcltest::testConstraint enableUnixInit32 1
} else {
tcltest::testConstraint enableUnixInit32 0
}
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
catch {set oldlc_all $env(LC_ALL)}
catch {set oldtcl_library $env(TCL_LIBRARY)}
unset -nocomplain env(TCL_LIBRARY)
} -constraints {unix stdio enableUnixInit32} -body {
set env(LANG) japanese
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
|
| ︙ | ︙ |
Changes to tests/unixNotfy.test.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
-constraints {noTk unix thread} \
-body {
update
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
| | | | 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 |
-constraints {noTk unix thread} \
-body {
update
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
thread::create "thread::send [thread::id] {set x ok}"
vwait x
set x
} \
-result {ok} \
-cleanup {
catch { close $f }
catch { removeFile foo }
}
test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
-constraints {noTk unix thread} \
-body {
update
set f1 [open [makeFile "" foo] w]
set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
close $f1
vwait y
close $f2
thread::create "thread::send [thread::id] {set x ok}"
vwait x
set x
} \
-result {ok} \
-cleanup {
catch { close $f1 }
catch { close $f2 }
|
| ︙ | ︙ |
Changes to tests/unload.test.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
set pkgua_unloaded {}
}
test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \
[list $dll $loaded] {
catch {rename pkgb_sub {}}
load [file join $testDir tcl9pkgb$ext] Pkgb child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
| | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
set pkgua_unloaded {}
}
test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \
[list $dll $loaded] {
catch {rename pkgb_sub {}}
load [file join $testDir tcl9pkgb$ext] Pkgb child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test unload-3.2 {basic loading of unloadable package in a safe interpreter} \
[list $dll $loaded] {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[load [file join $testDir tcl9pkgua$ext] Pkgua child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
|
| ︙ | ︙ |
Changes to tests/upvar.test.
| ︙ | ︙ | |||
517 518 519 520 521 522 523 |
} {1234}
catch {unset a}
test upvar-10.1 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
| | | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 |
} {1234}
catch {unset a}
test upvar-10.1 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
upvar 1 {*}{
} [return [incr n -[linenumber]]] x
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
#
# Tests for 'namespace upvar'. As the implementation is essentially the same as
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
namespace delete test_ns_1
} -result {}
test upvar-NS-3.1 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
| | | | | | | | 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 |
namespace delete test_ns_1
} -result {}
test upvar-NS-3.1 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
namespace upvar {*}{
} [return [incr n -[linenumber]]] x y
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
test upvar-NS-3.2 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
namespace upvar :: {*}{
} [return [incr n -[linenumber]]] x
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
test upvar-NS-3.3 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
variable x {*}{
} [return [incr n -[linenumber]]]
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/utf.test.
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
unset count
rename UniCharCaseCmpTest {}
proc GetUniCharTest {s index result} {
variable count
# Use quotes, not {} so test output shows exact string on error
test getunichar-1.$count "Tcl_GetUniChar $s $index" \
| | | | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
unset count
rename UniCharCaseCmpTest {}
proc GetUniCharTest {s index result} {
variable count
# Use quotes, not {} so test output shows exact string on error
test getunichar-1.$count "Tcl_GetUniChar $s $index" \
-constraints testgetunichar \
-body "testgetunichar $s $index" \
-result $result
incr count
}
variable count 1
set errorIndicator -1
GetUniCharTest abcd -2 $errorIndicator
GetUniCharTest abcd -1 $errorIndicator
GetUniCharTest abcd 0 97 ;# a -> ASCII 97
|
| ︙ | ︙ |
Changes to tests/utfext.test.
1 | # This file contains a collection of tests for Tcl_UtfToExternal and | | | > > | > > > > > > | > > > > > > > > > > > | | > | > > > > > > > > > > > > > > > > > > > | | | | | > > | > > > > | > > > | > > > > > > > > > > > > > > > > > > > > | > | | > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > | | | | | | | > > > | > | > > > | > > > > > > | > > > > > > > > > > | > > > > | > > > > > > > > > > > | > > | > > > > > | > > > > | > > > > > > > > > > | > | > > | > > > > > | > > | > > > > | > > > > > > | | > > > | > > > > | > | > > > > > > > > > | | > > > > > | > > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > | > | < | | | | > > | 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 |
# This file contains a collection of tests for Tcl_UtfToExternal and
# Tcl_UtfToExternal that exercise various combinations of flags,
# buffer lengths and fragmentation that cannot be tested by
# normal script level commands. There tests are NOT intended to check
# correct encodings; those are elsewhere.
#
# Copyright (c) 2023 Ashok P. Nadkarni
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testencoding [llength [info commands testencoding]]
namespace eval utftest {
# Format of table, indexed by encoding. The encodings are not exhaustive
# but one of each kind of encoding transform (algorithmic, table-driven,
# stateful, DBCS, MBCS).
# Each element is list of lists. Nested lists have following fields
# 0 comment (no spaces, might be used to generate id's as well)
# The combination of comment and internal hex (2) should be unique.
# 1 hex representation of internal *modified* utf-8 encoding. This is the
# source string for Tcl_UtfToExternal and expected result for
# Tcl_ExternalToUtf.
# 2 hex representation in specified encoding. This is the source string for
# Tcl_ExternalToUtf and expected result for Tcl_UtfToExternal.
# 3 internal fragmentation index - where to split field 1 for fragmentation
# tests. -1 to skip
# 4 external fragmentation index - where to split field 2 for fragmentation
# tests. -1 to skip
#
# THE HEX DEFINITIONS SHOULD SEPARATE EACH CHARACTER BY WHITESPACE
# (assumed by the charlimit tests)
lappend utfExtMap {*}{
ascii {
{basic {41 42 43} {41 42 43} -1 -1}
}
utf-8 {
{bmp {41 c3a9 42} {41 c3a9 42} 2 2}
{nonbmp-frag-1 {41 f09f9880 42} {41 f09f9880 42} 2 2}
{nonbmp-frag-2 {41 f09f9880 42} {41 f09f9880 42} 3 3}
{nonbmp-frag-3 {41 f09f9880 42} {41 f09f9880 42} 4 4}
{null {41 c080 42} {41 00 42} 2 -1}
}
cesu-8 {
{bmp {41 c3a9 42} {41 c3a9 42} 2 2}
{nonbmp-frag-surr-low {41 f09f9880 42} {41 eda0bd edb880 42} 2 2}
{nonbmp-split-surr {41 f09f9880 42} {41 eda0bd edb880 42} 3 -1}
{nonbmp-frag-surr-high {41 f09f9880 42} {41 eda0bd edb880 42} 4 6}
{null {41 c080 42} {41 00 42} 2 -1}
}
utf-16le {
{bmp {41 c3a9 42} {4100 e900 4200} 2 3}
{nonbmp {41 f09f9880 42} {4100 3dd8 00de 4200} 4 3}
{split-surrogate {41 f09f9080 42} {4100 3dd8 00dc 4200} 3 4}
{null {41 c080 42} {4100 0000 4200} 2 3}
}
utf-16be {
{bmp {41 c3a9 42} {0041 00e9 0042} 2 3}
{nonbmp {41 f09f9880 42} {0041 d83d de00 0042} 4 3}
{split-surrogate {41 f09f9080 42} {0041 d83d dc00 0042} 3 4}
{null {41 c080 42} {0041 0000 0042} 2 3}
}
utf-32le {
{bmp {41 c3a9 42} {41000000 e9000000 42000000} 2 3}
{nonbmp {41 f09f9880 42} {41000000 00f60100 42000000} 4 6}
{null {41 c080 42} {41000000 00000000 42000000} 2 3}
}
utf-32be {
{bmp {41 c3a9 42} {00000041 000000e9 00000042} 2 3}
{nonbmp {41 f09f9880 42} {00000041 0001f600 00000042} 4 3}
{null {41 c080 42} {00000041 00000000 00000042} 2 3}
}
iso8859-1 {
{basic {41 c3a9 42} {41 e9 42} 2 -1}
{null {41 c080 42} {41 00 42} 2 -1}
}
iso8859-3 {
{basic {41 c4a0 42} {41 d5 42} 2 -1}
{null {41 c080 42} {41 00 42} 2 -1}
}
shiftjis {
{basic {41 e4b98e 42} {41 8cc1 42} 3 2}
}
jis0208 {
{basic {e4b98e e590be} {3843 3863} 1 1}
}
iso2022-jp {
{frag-in-leadescape {58 e4b98e 5a} {58 1b2442 3843 1b2842 5a} 2 2}
{frag-in-char {58 e4b98e 5a} {58 1b2442 3843 1b2842 5a} 2 5}
{frag-in-trailescape {58 e4b98e 5a} {58 1b2442 3843 1b2842 5a} 2 8}
}
}
# Return a binary string containing nul terminator for encoding
proc hexnuls {enc} {
return [binary encode hex [encoding convertto $enc \x00]]
}
# The C wrapper fills entire destination buffer with FF.
# Anything beyond expected output should have FF's
proc fill {bin buflen} {
return [string range "$bin[string repeat \xFF $buflen]" 0 $buflen-1]
}
proc testutf {direction enc comment hexin hexout args} {
set id $comment-[join $hexin ""]
if {$direction eq "toutf"} {
set cmd Tcl_ExternalToUtf
} else {
set cmd Tcl_UtfToExternal
}
set in [binary decode hex $hexin]
set out [binary decode hex $hexout]
set dstlen 40 ;# Should be enough for all encoding tests
set status ok
set flags [list start end]
set constraints [list testencoding]
set profiles [encoding profiles]
while {[llength $args] > 1} {
set opt [lpop args 0]
switch $opt {
-flags { set flags [lpop args 0] }
-constraints { lappend constraints {*}[lpop args 0] }
-profiles { set profiles [lpop args 0] }
-status { set status [lpop args 0]}
default {
error "Unknown option \"$opt\""
}
}
}
if {[llength $args]} {
error "No value supplied for option [lindex $args 0]."
}
set result [list $status {} [fill $out $dstlen]]
test $cmd-$enc-$id-[join $flags -] "$cmd - $enc - $hexin - $flags" -body \
[list testencoding $cmd $enc $in $flags {} $dstlen] \
-result $result -constraints $constraints
foreach profile $profiles {
set flags2 [linsert $flags end $profile]
test $cmd-$enc-$id-[join $flags2 -] "$cmd - $enc - $hexin - $flags2" -body \
[list testencoding $cmd $enc $in $flags2 {} $dstlen] \
-result $result -constraints $constraints
}
}
proc testfragment {direction enc comment hexin hexout fragindex args} {
if {$fragindex < 0} {
# Single byte encodings so no question of fragmentation
return
}
set id $comment-[join $hexin ""]-fragment
if {$direction eq "toutf"} {
set cmd Tcl_ExternalToUtf
} else {
set cmd Tcl_UtfToExternal
}
set status1 multibyte; # Return status to expect after first call
while {[llength $args] > 1} {
set opt [lpop args 0]
switch $opt {
-status1 { set status1 [lpop args 0]}
default {
error "Unknown option \"$opt\""
}
}
}
set in [binary decode hex $hexin]
set infrag [string range $in 0 $fragindex-1]
set out [binary decode hex $hexout]
set dstlen 40 ;# Should be enough for all encoding tests
test $cmd-$enc-$id "$cmd - $enc - $hexin - frag" -constraints testencoding -body {
set frag1Result [testencoding $cmd $enc [string range $in 0 $fragindex-1] {start} 0 $dstlen frag1Read frag1Written]
lassign $frag1Result frag1Status frag1State frag1Decoded
set frag2Result [testencoding $cmd $enc [string range $in $frag1Read end] {end} $frag1State $dstlen frag2Read frag2Written]
lassign $frag2Result frag2Status frag2State frag2Decoded
set decoded [string cat [string range $frag1Decoded 0 $frag1Written-1] [string range $frag2Decoded 0 $frag2Written-1]]
list $frag1Status [expr {$frag1Read <= $fragindex}] \
$frag2Status [expr {$frag1Read+$frag2Read}] \
[expr {$frag1Written+$frag2Written}] $decoded
} -result [list $status1 1 ok [string length $in] [string length $out] $out]
}
proc testcharlimit {direction enc comment hexin hexout} {
set id $comment-[join $hexin ""]-charlimit
if {$direction eq "toutf"} {
set cmd Tcl_ExternalToUtf
} else {
set cmd Tcl_UtfToExternal
}
set maxchars [llength $hexout]
set in [binary decode hex $hexin]
set out [binary decode hex $hexout]
set dstlen 40 ;# Should be enough for all encoding tests
for {set nchars 0} {$nchars <= $maxchars} {incr nchars} {
set expected_bytes [binary decode hex [lrange $hexout 0 $nchars-1]]
set expected_nwritten [string length $expected_bytes]
test $cmd-$enc-$id-$nchars "$cmd - $enc - $hexin - nchars $nchars" -constraints testencoding -body {
set charlimit $nchars
lassign [testencoding $cmd $enc $in \
{start end charlimit} 0 $dstlen nread nwritten charlimit] \
status state buf
list $status $nwritten [string range $buf 0 $nwritten-1]
} -result [list [expr {$nchars == $maxchars ? "ok" : "nospace"}] $expected_nwritten $expected_bytes]
}
}
proc testspacelimit {direction enc comment hexin hexout} {
set id $comment-[join $hexin ""]-spacelimit
# Triple the input to avoid pathological short input case where
# whereby nothing is written to output. The test below
# requires $nchars > 0
set hexin $hexin$hexin$hexin
set hexout $hexout$hexout$hexout
set flags [list start end]
set constraints [list testencoding]
set maxchars [llength $hexout]
set in [binary decode hex $hexin]
set out [binary decode hex $hexout]
set dstlen [expr {[string length $out] - 1}]; # Smaller buffer than needed
if {$direction eq "toutf"} {
set cmd Tcl_ExternalToUtf
set str [encoding convertfrom $enc $in]
} else {
set cmd Tcl_UtfToExternal
set str [encoding convertfrom $enc $out]
}
# Note the tests are loose because the some encoding operations will
# stop even there is actually still room in the destination. For example,
# below only one char is written though there is room in the output.
# % testencoding Tcl_ExternalToUtf ascii abc {start end} {} 5 nread nwritten nchars
# nospace {} aÿÿÿ#
# % puts $nread,$nwritten,$nchars
# 1,1,1
#
test $cmd-$enc-$id-[join $flags -] "$cmd - $enc - $hexin - $flags" \
-constraints $constraints \
-body {
lassign [testencoding $cmd $enc $in $flags {} $dstlen nread nwritten nchars] status state buf
list \
$status \
[expr {$nread < [string length $in]}] \
[expr {$nwritten <= $dstlen}] \
[expr {$nchars > 0 && $nchars < [string length $str]}] \
[expr {[string range $out 0 $nwritten-1] eq [string range $buf 0 $nwritten-1]}]
} -result {nospace 1 1 1 1}
}
#
# Basic tests
foreach {enc testcases} $utfExtMap {
foreach testcase $testcases {
lassign $testcase {*}{comment utfhex hex internalfragindex externalfragindex}
# Basic test - TCL_ENCODING_START|TCL_ENCODING_END
# Note by default output should be terminated with \0
set encnuls [hexnuls $enc]
testutf toutf $enc $comment $hex ${utfhex}00
testutf fromutf $enc $comment $utfhex $hex$encnuls
# Test TCL_ENCODING_NO_TERMINATE
testutf toutf $enc $comment $hex $utfhex -flags {start end noterminate}
# noterminate is specific to ExternalToUtf,
# should have no effect in other direction
testutf fromutf $enc $comment $utfhex $hex$encnuls -flags {start end noterminate}
# Fragments
testfragment toutf $enc $comment $hex $utfhex $externalfragindex
testfragment fromutf $enc $comment $utfhex $hex $internalfragindex
# Char limits - note no fromutf as Tcl_UtfToExternal does not support it
testcharlimit toutf $enc $comment $hex $utfhex
# Space limits
testspacelimit toutf $enc $comment $hex $utfhex
testspacelimit fromutf $enc $comment $utfhex $hex
}
}
# Special cases - cesu2 high and low surrogates in separate fragments
# This will (correctly) return "ok", not "multibyte" after first frag
testfragment toutf cesu-8 nonbmp-split-surr \
{41 eda0bd edb880 42} {41 f09f9880 42} 4 -status1 ok
# Bug regression tests
test Tcl_UtfToExternal-bug-183a1adcc0 {buffer overflow} -body {
testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1
} -result [list nospace {} \xFF] -constraints testencoding
test Tcl_ExternalToUtf-bug-5be203d6ca {
truncated prefix in table encoding
} -body {
set src \x82\x4F\x82\x50\x82
set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end tcl8} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
} -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] -constraints testencoding
}
namespace delete utftest
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/util.test.
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
lassign [testdoubledigits $double [string length $digits1] e] \
outdigits decpt outsign
if {[string index $digits2 0] >= 5} {
incr digits1
}
if {$outsign != $signum || $outdigits != $digits1 || $decpt != $decexp} {
return -code error "result is ${outsign}0.${outdigits}E$decpt\
| | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
lassign [testdoubledigits $double [string length $digits1] e] \
outdigits decpt outsign
if {[string index $digits2 0] >= 5} {
incr digits1
}
if {$outsign != $signum || $outdigits != $digits1 || $decpt != $decexp} {
return -code error "result is ${outsign}0.${outdigits}E$decpt\
should be ${signum}0.${digits1}E$decexp"
}
}
test util-1.1 {TclFindElement procedure - binary element in middle of list} {
lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
|
| ︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 |
} {0 0 -}
# Verdonk test vectors
test util-13.1 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 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 |
} {0 0 -}
# Verdonk test vectors
test util-13.1 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1754e31cd072da E+1008 +4_000000000000000000& E+303
}
-result {}
}
test util-13.2 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1afcef51f0fb5f E+265 -1_000000000000000000& E+80
}
-result {}
}
test util-13.3 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1754e31cd072da E+1006 +1_000000000000000000& E+303
}
-result {}
}
test util-13.4 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1754e31cd072da E+1007 -2_000000000000000000& E+303
}
-result {}
}
test util-13.5 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1e07b27dd78b14 E-848 +1_00000000000000000& E-255
}
-result {}
}
test util-13.6 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1e29e9c56687fe E-709 -7_00000000000000000& E-214
}
-result {}
}
test util-13.7 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1be03d0bf225c7 E-137 +1_00000000000000000& E-41
}
-result {}
}
test util-13.8 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1a2fe76a3f9475 E-499 -1_00000000000000000& E-150
}
-result {}
}
test util-13.9 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 19a2028368022e E+1019 +8_999999999999999999& E+306
}
-result {}
}
test util-13.10 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1317e5ef3ab327 E+509 -1_999999999999999999& E+153
}
-result {}
}
test util-13.11 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1317e5ef3ab327 E+510 +3_99999999999999999& E+153
}
-result {}
}
test util-13.12 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1317e5ef3ab327 E+511 -7_99999999999999999& E+153
}
-result {}
}
test util-13.13 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1eb8e84fa0b278 E-1008 +6_999999999999999999& E-304
}
-result {}
}
test util-13.14 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -13339131c46f8b E-1004 -6_999999999999999999& E-303
}
-result {}
}
test util-13.15 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1c0f92a6276c9d E-162 +2_999999999999999999& E-49
}
-result {}
}
test util-13.16 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -15ce1f143d7ad2 E-443 -5_99999999999999999& E-134
}
-result {}
}
test util-13.17 {just over exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1c0794d9d40e96 E-301 +43_000000000000000000& E-92
}
-result {}
}
test util-13.18 {just over exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1c0794d9d40e96 E-300 -86_000000000000000000& E-92
}
-result {}
}
test util-13.19 {just over exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1cd5bee57763e6 E-241 +51_000000000000000000& E-74
}
-result {}
}
test util-13.20 {just under exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1d1c26db7d0dae E+651 +16_999999999999999999& E+195
}
-result {}
}
test util-13.21 {just under exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -13f7ced916872b E-5 -38_999999999999999999& E-3
}
-result {}
}
test util-13.22 {just over exact - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 17d93193f78fc6 E+588 +151_0000000000000000000& E+175
}
-result {}
}
test util-13.23 {just over exact - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1a82a1631eeb30 E-625 -119_000000000000000000& E-190
}
-result {}
}
test util-13.24 {just under exact - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -16c309024bab4b E+290 -282_999999999999999999& E+85
}
-result {}
}
test util-13.25 {just over exact - 8 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1dbbac6f83a821 E-800 +27869147_0000000000000000000& E-248
}
-result {}
}
test util-13.26 {just under exact - 9 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1c569e968e0944 E+430 -491080653_9999999999999999999& E+121
}
-result {}
}
test util-13.27 {just under exact - 9 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1c569e968e0944 E+429 +245540326_9999999999999999999& E+121
}
-result {}
}
test util-13.28 {just over exact - 10 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1fc575867314ee E-330 -9078555839_0000000000000000000& E-109
}
-result {}
}
test util-13.29 {just under exact - 10 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1c569e968e0944 E+428 -1227701634_9999999999999999999& E+120
}
-result {}
}
test util-13.30 {just over exact - 11 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1fc575867314ee E-329 +18157111678_0000000000000000000& E-109
}
-result {}
}
test util-13.31 {just over exact - 14 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -18bf7e7fa6f02a E-196 -15400733123779_0000000000000000000& E-72
}
-result {}
}
test util-13.32 {just over exact - 17 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -13de005bd620df E+217 -26153245263757307_0000000000000000000& E+49
}
-result {}
}
test util-13.33 {just over exact - 18 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1f92bacb3cb40c E+718 +272104041512242479_0000000000000000000& E+199
}
-result {}
}
test util-13.34 {just over exact - 18 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1f92bacb3cb40c E+719 -544208083024484958_0000000000000000000& E+199
}
-result {}
}
test util-13.35 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 142dbf25096cf5 E+148 +4_500000000000000000& E+44
}
-result {}
}
test util-13.36 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1afcef51f0fb5f E+263 -2_500000000000000000& E+79
}
-result {}
}
test util-13.37 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 102498ea6df0c4 E+145 +4_500000000000000000& E+43
}
-result {}
}
test util-13.38 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1754e31cd072da E+1004 -2_500000000000000000& E+302
}
-result {}
}
test util-13.39 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 12deac01e2b4f7 E-557 +2_50000000000000000& E-168
}
-result {}
}
test util-13.40 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1b1df536c13eee E-307 -6_50000000000000000& E-93
}
-result {}
}
test util-13.41 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 10711fed5b19a4 E-154 +4_50000000000000000& E-47
}
-result {}
}
test util-13.42 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -148d67e8b1e00d E-151 -4_50000000000000000& E-46
}
-result {}
}
test util-13.43 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1c8c574c0c6be7 E+187 +3_49999999999999999& E+56
}
-result {}
}
test util-13.44 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1756183c147514 E+206 -1_49999999999999999& E+62
}
-result {}
}
test util-13.45 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 12ab469676c410 E+203 +1_49999999999999999& E+61
}
-result {}
}
test util-13.46 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1539684e774b48 E+246 -1_49999999999999999& E+74
}
-result {}
}
test util-13.47 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 12e5f5dfa4fe9d E-286 +9_499999999999999999& E-87
}
-result {}
}
test util-13.48 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1bdc2417bf7787 E-838 -9_499999999999999999& E-253
}
-result {}
}
test util-13.49 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1eb8e84fa0b278 E-1009 +3_499999999999999999& E-304
}
-result {}
}
test util-13.50 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1e3cbc9907fdc8 E-290 -9_499999999999999999& E-88
}
-result {}
}
test util-13.51 {just over half ulp - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 10ad836f269a17 E-324 +30_500000000000000000& E-99
}
-result {}
}
test util-13.52 {just over half ulp - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1b39ae1909c31b E-687 -26_500000000000000000& E-208
}
-result {}
}
test util-13.53 {just over half ulp - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1b2ab18615fcc6 E-576 +686_500000000000000000& E-176
}
-result {}
}
test util-13.54 {just over half ulp - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -13e1f90a573064 E-624 -178_500000000000000000& E-190
}
-result {}
}
test util-13.55 {just under half ulp - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 16c309024bab4b E+289 +141_499999999999999999& E+85
}
-result {}
}
test util-13.56 {just under half ulp - 4 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -159bd3ad46e346 E+193 -1695_499999999999999999& E+55
}
-result {}
}
test util-13.57 {just under half ulp - 4 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1df4170f0fdecc E+124 +3981_499999999999999999& E+34
}
-result {}
}
test util-13.58 {just over half ulp - 6 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 17e1e0f1c7a4ac E+415 +126300_5000000000000000000& E+120
}
-result {}
}
test util-13.59 {just over half ulp - 6 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1dda592e398dd7 E+418 -126300_5000000000000000000& E+121
}
-result {}
}
test util-13.60 {just under half ulp - 7 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1e597c0b94b7ae E+453 -4411845_499999999999999999& E+130
}
-result {}
}
test util-13.61 {just under half ulp - 9 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1c569e968e0944 E+427 +613850817_4999999999999999999& E+120
}
-result {}
}
test util-13.62 {just under half ulp - 9 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1c569e968e0944 E+428 -122770163_49999999999999999999& E+121
}
-result {}
}
test util-13.63 {just over half ulp - 18 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 17ae0c186d8709 E+719 +408156062268363718_5000000000000000000& E+199
}
-result {}
}
test util-13.64 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 152d02c7e14af7 E+76 +1_0000000000000000& E+23
}
-result {}
}
test util-13.65 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -19d971e4fe8402 E+89 -1_0000000000000000& E+27
}
-result {}
}
test util-13.66 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 19d971e4fe8402 E+90 +2_0000000000000000& E+27
}
-result {}
}
test util-13.67 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -19d971e4fe8402 E+91 -4_0000000000000000& E+27
}
-result {}
}
test util-13.68 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 15798ee2308c3a E-27 +1_0000000000000000& E-8
}
-result {}
}
test util-13.69 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -15798ee2308c3a E-26 -2_0000000000000000& E-8
}
-result {}
}
test util-13.70 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 15798ee2308c3a E-25 +4_0000000000000000& E-8
}
-result {}
}
test util-13.71 {just over exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1ef2d0f5da7dd9 E-84 -1_0000000000000000& E-25
}
-result {}
}
test util-13.72 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1a784379d99db4 E+78 +4_9999999999999999& E+23
}
-result {}
}
test util-13.73 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1a784379d99db4 E+80 -1_9999999999999999& E+24
}
-result {}
}
test util-13.74 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 13da329b633647 E+81 +2_9999999999999999& E+24
}
-result {}
}
test util-13.75 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1cf389cd46047d E+85 -6_9999999999999999& E+25
}
-result {}
}
test util-13.76 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 19999999999999 E-3 +1_99999999999999999& E-1
}
-result {}
}
test util-13.77 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -13333333333333 E-2 -2_99999999999999999& E-1
}
-result {}
}
test util-13.78 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 16849b86a12b9b E-48 +4_99999999999999999& E-15
}
-result {}
}
test util-13.79 {just under exact - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -16849b86a12b9b E-46 -1_99999999999999999& E-14
}
-result {}
}
test util-13.80 {just over exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 17ccfc73126788 E-71 +63_00000000000000000& E-23
}
-result {}
}
test util-13.81 {just over exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1dc03b8fd7016a E-68 -63_00000000000000000& E-22
}
-result {}
}
test util-13.82 {just under exact - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 13f7ced916872b E-5 +38_999999999999999999& E-3
}
-result {}
}
test util-13.83 {just over exact - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1b297cad9f70b6 E+97 +269_000000000000000000& E+27
}
-result {}
}
test util-13.84 {just over exact - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1b297cad9f70b6 E+98 -538_00000000000000000& E+27
}
-result {}
}
test util-13.85 {just over exact - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1cdc06b20ef183 E-82 +373_00000000000000000& E-27
}
-result {}
}
test util-13.86 {just over exact - 4 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1b297cad9f70b6 E+96 +1345_00000000000000000& E+26
}
-result {}
}
# this one is not 4 digits, it is 3, and it is covered above.
test util-13.87 {just over exact - 4 digits} {*}{
-constraints {testdoubledigits knownBadTest}
-body {
verdonk_test -1b297cad9f70b6 E+97 -2690_00000000000000000& E+26
}
-result {}
}
test util-13.88 {just over exact - 5 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -150a246ecd44f3 E-63 -14257_00000000000000000& E-23
}
-result {}
}
test util-13.89 {just under exact - 6 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -119b96f36ec68b E-19 -209900_999999999999999999& E-11
}
-result {}
}
test util-13.90 {just over exact - 11 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1c06d366394441 E-35 +50980203373_000000000000000000& E-21
}
-result {}
}
test util-13.91 {just under exact - 12 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1f58ac4db68c90 E+122 -104166211810_99999999999999999& E+26
}
-result {}
}
test util-13.92 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 19d971e4fe8402 E+87 +2_5000000000000000& E+26
}
-result {}
}
test util-13.93 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1dc74be914d16b E+81 -4_500000000000000& E+24
}
-result {}
}
test util-13.94 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 14adf4b7320335 E+84 +2_500000000000000& E+25
}
-result {}
}
test util-13.95 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1ae22487c1042b E+85 -6_5000000000000000& E+25
}
-result {}
}
test util-13.96 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 187fe49aab41e0 E-54 +8_5000000000000000& E-17
}
-result {}
}
test util-13.97 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1f5c05e4b23fd7 E-61 -8_5000000000000000& E-19
}
-result {}
}
test util-13.98 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1faa7ab552a552 E-42 +4_5000000000000000& E-13
}
-result {}
}
test util-13.99 {just over half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1b7cdfd9d7bdbb E-36 -2_5000000000000000& E-11
}
-result {}
}
test util-13.100 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 13da329b633647 E+80 +1_4999999999999999& E+24
}
-result {}
}
test util-13.101 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1cf389cd46047d E+84 -3_49999999999999999& E+25
}
-result {}
}
test util-13.102 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1f04ef12cb04cf E+85 +7_4999999999999999& E+25
}
-result {}
}
test util-13.103 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1f04ef12cb04cf E+86 -1_4999999999999999& E+26
}
-result {}
}
test util-13.104 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 13333333333333 E-3 +1_49999999999999999& E-1
}
-result {}
}
test util-13.105 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -107e1fe91b0b70 E-36 -1_49999999999999999& E-11
}
-result {}
}
test util-13.106 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 149da7e361ce4c E-33 +1_49999999999999999& E-10
}
-result {}
}
test util-13.107 {just under half ulp - 1 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -19c511dc3a41df E-30 -1_49999999999999999& E-9
}
-result {}
}
test util-13.108 {just over half ulp - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1aa83d74267822 E+93 -16_5000000000000000& E+27
}
-result {}
}
test util-13.109 {just over half ulp - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 18f1d5969453de E+89 +96_5000000000000000& E+25
}
-result {}
}
test util-13.110 {just over half ulp - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 11d9bd564dcda6 E-70 +94_50000000000000000& E-23
}
-result {}
}
test util-13.111 {just over half ulp - 2 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1a58973ecbede6 E-48 -58_50000000000000000& E-16
}
-result {}
}
test util-13.112 {just over half ulp - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1b297cad9f70b6 E+95 +672_50000000000000000& E+26
}
-result {}
}
test util-13.113 {just over half ulp - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -1b297cad9f70b6 E+96 -134_500000000000000000& E+27
}
-result {}
}
test util-13.114 {just over half ulp - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1cdc06b20ef183 E-83 +186_50000000000000000& E-27
}
-result {}
}
test util-13.115 {just over half ulp - 3 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -136071dcae4565 E-47 -860_50000000000000000& E-17
}
-result {}
}
test util-13.116 {just over half ulp - 6 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1cb968d297dde8 E+99 +113788_50000000000000000& E+25
}
-result {}
}
test util-13.117 {just over half ulp - 6 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test -11f3e1839eeab1 E+103 -113788_50000000000000000& E+26
}
-result {}
}
test util-13.118 {just under half ulp - 9 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1e9cec176c96f8 E+117 +317903333_49999999999999999& E+27
}
-result {}
}
test util-13.119 {just over half ulp - 11 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1c06d366394441 E-36 +25490101686_500000000000000000& E-21
}
-result {}
}
test util-13.120 {just under half ulp - 11 digits} {*}{
-constraints testdoubledigits
-body {
verdonk_test 1f58ac4db68c90 E+121 +52083105905_49999999999999999& E+26
}
-result {}
}
test util-14.1 {funky NaN} {*}{
-constraints {ieeeFloatingPoint controversialNaN}
-body {
|
| ︙ | ︙ |
Changes to tests/var.test.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
| | | | | | | | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
return [lindex [split [memory info] \n] 3 3]
}
proc leaktest {script {iterations 3}} {
set end [getbytes]
for {set i 0} {$i < $iterations} {incr i} {
uplevel 1 $script
set tmp $end
set end [getbytes]
}
return [expr {$end - $tmp}]
}
}
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
|
| ︙ | ︙ | |||
61 62 63 64 65 66 67 |
} -result {11 11 38 38}
set ::x "global value"
namespace eval test_ns_var {
variable x "namespace value"
}
test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
namespace eval test_ns_var {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} -result {11 11 38 38}
set ::x "global value"
namespace eval test_ns_var {
variable x "namespace value"
}
test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
namespace eval test_ns_var {
proc p {} {
global x ;# specifies TCL_GLOBAL_ONLY to get global x
return $x
}
}
test_ns_var::p
} {global value}
test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} {
namespace eval test_ns_var {
proc q {} {
variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x
return $x
}
}
test_ns_var::q
} {namespace value}
test var-1.4 {TclLookupVar, no active call frame implies global namespace var} {
set x
} {global value}
test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} {
namespace eval test_ns_var {set x}
} {namespace value}
test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} {
namespace eval test_ns_var {set ::x}
} {global value}
test var-1.7 {TclLookupVar, error finding namespace var} -body {
set a:::b
} -returnCodes error -result {can't read "a:::b": no such variable}
test var-1.8 {TclLookupVar, error finding namespace var} -body {
set ::foobarfoo
} -returnCodes error -result {can't read "::foobarfoo": no such variable}
test var-1.9 {TclLookupVar, create new namespace var} {
namespace eval test_ns_var {
set v hello
}
} {hello}
test var-1.10 {TclLookupVar, create new namespace var} -setup {
catch {unset y}
} -body {
namespace eval test_ns_var {
set ::y 789
}
set y
} -result {789}
test var-1.11 {TclLookupVar, error creating new namespace var} -body {
namespace eval test_ns_var {
set ::test_ns_var::foo::bar 314159
}
} -returnCodes error -result {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}
test var-1.12 {TclLookupVar, error creating new namespace var} -body {
namespace eval test_ns_var {
set ::test_ns_var::foo:: 1997
}
} -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist}
test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} {
catch {unset aNeWnAmEiNnS}
namespace eval test_ns_var {
namespace eval test_ns_var2::test_ns_var3 {
set aNeWnAmEiNnS 77777
}
# namespace which builds a name by traversing nsPtr chain to ::
namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS
}
} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS}
test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} {
namespace eval test_ns_var {
set : 123
set v: 456
set x:y: 789
list [set :] [set v:] [set x:y:] \
${:} ${v:} ${x:y:} \
[expr {":" in [info vars]}] \
[expr {"v:" in [info vars]}] \
[expr {"x:y:" in [info vars]}]
}
} {123 456 789 123 456 789 1 1 1}
test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} {
namespace eval test_ns_var {
variable foo 2
}
proc p {} {
variable ::test_ns_var::foo
lappend result [catch {set foo} msg] $msg
namespace delete ::test_ns_var
lappend result [catch {set foo 3} msg] $msg
lappend result [catch {set foo(3) 3} msg] $msg
}
p
} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} {
namespace eval test_ns_var {
variable result
namespace eval subns {
variable foo 2
}
upvar 0 subns::foo foo
lappend result [catch {set foo} msg] $msg
namespace delete subns
lappend result [catch {set foo 3} msg] $msg
lappend result [catch {set foo(3) 3} msg] $msg
namespace delete [namespace current]
set result
}
} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} {
namespace eval test_ns_var {
variable result
proc p {} {
array set x {1 2 3 4}
upvar 0 x(1) foo
lappend result [catch {set foo} msg] $msg
unset x
lappend result [catch {set foo 3} msg] $msg
}
set result [p]
namespace delete [namespace current]
set result
}
} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup {
unset -nocomplain test_ns_var::x
} -body {
namespace eval test_ns_var {
variable result {}
variable x
array set x {1 2 3 4}
upvar 0 x(1) foo
lappend result [catch {set foo} msg] $msg
unset x
lappend result [catch {set foo 3} msg] $msg
namespace delete [namespace current]
set result
}
} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-1.19 {TclLookupVar, right error message when parsing variable name} -body {
[format set] thisvar(doesntexist)
} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup {
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
} {1 2}
test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup {
catch {unset x}
} -body {
set x 1997
proc p {} {
| | | | | | | | | | | 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 |
} {1 2}
test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup {
catch {unset x}
} -body {
set x 1997
proc p {} {
global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x
return $x
}
p
} -result {1997}
test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} {
namespace eval test_ns_var {
catch {unset v}
variable v 1998
proc p {} {
variable v ;# TCL_NAMESPACE_ONLY specified for other var x
return $v
}
p
}
} {1998}
test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup {
catch {unset a}
} -constraints testupvar -body {
set a 123321
proc p {} {
|
| ︙ | ︙ | |||
285 286 287 288 289 290 291 |
list [set xxxxx] [set aaaaa]
} -result {77777 77777}
test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup {
catch {unset a}
} -body {
set a 121212
namespace eval test_ns_var {
| | | | | 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 |
list [set xxxxx] [set aaaaa]
} -result {77777 77777}
test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup {
catch {unset a}
} -body {
set a 121212
namespace eval test_ns_var {
upvar ::a vvv
set vvv
}
} -result {121212}
test var-3.7 {MakeUpvar, my var has ::s} -setup {
catch {unset a}
} -body {
set a 789789
upvar #0 a test_ns_var::lnk
namespace eval test_ns_var {
set lnk
}
} -result {789789}
test var-3.8 {MakeUpvar, my var already exists in global ns} -setup {
upvar #0 aaaaa xxxxx
catch {unset aaaaa}
catch {unset xxxxx}
} -body {
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 |
catch {unset a}
} -body {
set a bar
namespace which -variable a
} -result {::a}
test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
namespace eval test_ns_var {
| | | | | | | | | | | | | | | | 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 |
catch {unset a}
} -body {
set a bar
namespace which -variable a
} -result {::a}
test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
namespace eval test_ns_var {
variable martha
namespace which -variable martha
}
} {::test_ns_var::martha}
test var-5.3 {Tcl_GetVariableFullName, namespace variable} -setup {
namespace eval test_ns_var {variable martha}
} -body {
namespace which -variable test_ns_var::martha
} -result {::test_ns_var::martha}
test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
namespace eval test_ns_var {
variable boeing 777
}
apply {{} {
global ::test_ns_var::boeing
set boeing
}}
} {777}
test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
namespace eval test_ns_var {
namespace eval test_ns_nested {
variable java java
}
proc p {} {
global ::test_ns_var::test_ns_nested::java
set java
}
}
test_ns_var::p
} {java}
test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {
namespace eval ::test_ns_var::test_ns_nested {}
set ::test_ns_var::test_ns_nested:: 24
apply {{} {
global ::test_ns_var::test_ns_nested::
set {}
}}
} {24}
test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} {
# Test for Tcl Bug 480176
set :v broken
proc p {} {
global :v
|
| ︙ | ︙ | |||
420 421 422 423 424 425 426 |
p
} {}
test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup {
catch {namespace delete test_ns_var}
} -body {
namespace eval test_ns_var {
| | | | | | | | | | | | | | | | | | | | | 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 |
p
} {}
test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup {
catch {namespace delete test_ns_var}
} -body {
namespace eval test_ns_var {
variable one 1
}
list [info vars test_ns_var::*] [set test_ns_var::one]
} -result {::test_ns_var::one 1}
test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
set two 2222222
namespace eval test_ns_var {
variable two
}
list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
} {0 1 {can't read "test_ns_var::two": no such variable}}
test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} -setup {
catch {namespace delete test_ns_var}
namespace eval test_ns_var {variable one 1}
} -body {
namespace eval test_ns_var {
variable two 2
}
list [lsort [info vars test_ns_var::*]] \
[namespace eval test_ns_var {set two}]
} -result [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup {
catch {namespace delete test_ns_var}
namespace eval test_ns_var {variable one 1; variable two 2}
} -body {
namespace eval test_ns_var {
variable three 3 four 4
}
list [lsort [info vars test_ns_var::*]] \
[namespace eval test_ns_var {expr {$three+$four}}]
} -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]
test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup {
catch {unset a}
catch {unset five}
catch {unset six}
} -body {
set a ""
set five 555
set six 666
namespace eval test_ns_var {
variable five 5 six
lappend ::a $five
}
lappend a $test_ns_var::five \
[set test_ns_var::six 6] [set test_ns_var::six] $six
} -cleanup {
catch {unset five}
catch {unset six}
} -result {5 5 6 6 666}
test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup {
catch {unset newvar}
} -body {
namespace eval test_ns_var {
variable ::newvar cheers!
}
return $newvar
} -cleanup {
catch {unset newvar}
} -result {cheers!}
test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body {
namespace eval test_ns_var {
variable sev:::en 7
}
} -result {can't define "sev:::en": parent namespace doesn't exist}
test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
set a ""
namespace eval test_ns_var {
variable eight 8
lappend ::a $eight
variable eight
lappend ::a $eight
}
set a
} {8 8}
test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup {
catch {namespace delete test_ns_var2}
} -body {
set a ""
namespace eval test_ns_var2 {
variable x 123
variable y
variable z
}
lappend a [lsort [info vars test_ns_var2::*]]
lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
[info exists test_ns_var2::z]
lappend a [list [catch {set test_ns_var2::y} msg] $msg]
lappend a [lsort [info vars test_ns_var2::*]]
lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
lappend a [set test_ns_var2::y hello]
lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
lappend a [lsort [info vars test_ns_var2::*]]
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 |
[lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\
{1 {can't unset "test_ns_var2::z": no such variable}}\
{}]
test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup {
namespace eval test_ns_var { variable eight 8 }
} -body {
namespace eval test_ns_var {
| | | | | | | | | | | | | 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 |
[lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\
{1 {can't unset "test_ns_var2::z": no such variable}}\
{}]
test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup {
namespace eval test_ns_var { variable eight 8 }
} -body {
namespace eval test_ns_var {
proc p {} {
variable eight
list [set eight] [info vars]
}
p
}
} -result {8 eight}
test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup {
namespace eval test_ns_var { variable eight 8 }
} -body {
proc p {} { ;# note this proc is at global :: scope
variable test_ns_var::eight
list [set eight] [info vars]
}
p
} -result {8 eight}
test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
variable {} {My name is empty}
}
proc p {} { ;# note this proc is at global :: scope
variable test_ns_var::
list [set {}] [info vars]
}
p
} {{My name is empty} {{}}}
test var-7.13 {Tcl_VariableObjCmd, variable named ":"} {
namespace eval test_ns_var {
variable : {My name is ":"}
proc p {} {
variable :
list [set :] [info vars]
}
p
}
} {{My name is ":"} :}
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
} {}
test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup {
catch {namespace delete test_ns_var}
catch {unset a}
} -body {
namespace eval test_ns_var {
| | | | | | | | | | | 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 |
} {}
test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup {
catch {namespace delete test_ns_var}
catch {unset a}
} -body {
namespace eval test_ns_var {
variable v 123
variable info ""
proc traceUnset {name1 name2 op} {
variable info
set info [concat $info [list $name1 $name2 $op]]
}
trace add var v unset [namespace code traceUnset]
}
list [unset test_ns_var::v] $test_ns_var::info
} -result {{} {test_ns_var::v {} unset}}
test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup {
catch {namespace delete test_ns_var}
catch {unset a}
} -body {
set info ""
namespace eval test_ns_var {
variable v 123 1
trace add var v unset ::traceUnset
}
proc traceUnset {name1 name2 op} {
set ::info [concat $::info [list $name1 $name2 $op]]
}
list [namespace delete test_ns_var] $::info
} -result {{} {::test_ns_var::v {} unset}}
|
| ︙ | ︙ | |||
808 809 810 811 812 813 814 |
array nextelement a $s
}}
} -returnCodes error -result {couldn't find search "s-1-a"}
test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body {
apply {{} {
array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
set s [array startsearch a]
| | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 |
array nextelement a $s
}}
} -returnCodes error -result {couldn't find search "s-1-a"}
test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body {
apply {{} {
array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
set s [array startsearch a]
unset a(ff)
array nextelement a $s
}}
} -returnCodes error -result {couldn't find search "s-1-a"}
test var-14.1 {array names syntax} -body {
array names foo bar baz snafu
} -returnCodes 1 -match glob -result *
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
} -result baz
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
set foo bar
| | | | | | 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 |
} -result baz
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
set foo bar
unset foo {*}{
} [return [incr n -[linenumber]]]
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
test var-22.0 {leak in array element unset: Bug a3309d01db} -setup {
proc doit k {
variable A
set A($k) {}
foreach n [array names A] {
if {$n <= $k-1} {
unset A($n)
}
}
}
} -constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
doit $i
set tmp $end
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
rename doit {}
} -result 0
test var-22.1 {leak in localVarName internalrep: Bug 80304238ac} -setup {
|
| ︙ | ︙ | |||
1051 1052 1053 1054 1055 1056 1057 |
}
interp delete child
}
} -constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
doit
| | | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 |
}
interp delete child
}
} -constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
doit
set tmp $end
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
rename doit {}
} -result 0
test var-22.2 {leak in parsedVarName} -constraints memory -body {
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 |
} -returnCodes error -body {
array for {k v} a {}
} -result {"a" isn't an array}
test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup {
catch {rename p ""}
} -returnCodes error -body {
apply {{x} {
| | | | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
} -returnCodes error -body {
array for {k v} a {}
} -result {"a" isn't an array}
test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup {
catch {rename p ""}
} -returnCodes error -body {
apply {{x} {
if {$x==1} {
return [array for {k v} a {}]
}
set a(x) 123
}} 1
} -result {"a" isn't an array}
test var-23.7 {array enumeration} -setup {
unset -nocomplain a
set reslist [list]
} -body {
array set a {a 1 b 2 c 3}
|
| ︙ | ︙ | |||
1139 1140 1141 1142 1143 1144 1145 |
unset -nocomplain a
set reslist [list]
} -body {
set retval {}
try {
array set a {a 1 b 2 c 3 d 4}
array for {k v} a {
| | | | | | | | | | | | | 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 |
unset -nocomplain a
set reslist [list]
} -body {
set retval {}
try {
array set a {a 1 b 2 c 3 d 4}
array for {k v} a {
lappend reslist $k $v
if { $k eq "a" } {
unset a(c)
}
}
lsort -stride 2 -index 0 $reslist
} on error {err res} {
set retval [dict get $res -errorinfo]
}
set retval
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
unset -nocomplain retval
} -result {array changed during iteration*}
test var-23.11 {array enumeration, insert key} -match glob -setup {
unset -nocomplain a
set reslist [list]
} -body {
set retval {}
try {
array set a {a 1 b 2 c 3 d 4}
array for {k v} a {
lappend reslist $k $v
if { $k eq "a" } {
set a(e) 5
}
}
lsort -stride 2 -index 0 $reslist
} on error {err res} {
set retval [dict get $res -errorinfo]
}
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
} -result {array changed during iteration*}
test var-23.12 {array enumeration, change value} -setup {
unset -nocomplain a
set reslist [list]
} -body {
array set a {a 1 b 2 c 3}
array for {k v} a {
lappend reslist $k $v
if { $k eq "a" } {
set a(c) 9
}
}
lsort -stride 2 -index 0 $reslist
} -cleanup {
unset -nocomplain a
unset -nocomplain reslist
} -result {a 1 b 2 c 9}
test var-23.13 {array enumeration, number of traces} -setup {
|
| ︙ | ︙ |
Changes to tests/while-old.test.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
}
set value
} 6
test while-old-1.4 {basic while loops, multiline test expr} {
set value 1
while {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
| | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
}
set value
} 6
test while-old-1.4 {basic while loops, multiline test expr} {
set value 1
while {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
incr value
break
}
set value
} {2}
test while-old-1.5 {basic while loops, test expr in quotes} {
set value 1
while "0 < 3" {set value 2; break}
set value
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
test while-old-4.3 {errors in while loops} {
set err [catch {while 1 2 3} msg]
list $err $msg
} {1 {wrong # args: should be "while test command"}}
test while-old-4.4 {errors in while loops} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
| | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
test while-old-4.3 {errors in while loops} {
set err [catch {while 1 2 3} msg]
list $err $msg
} {1 {wrong # args: should be "while test command"}}
test while-old-4.4 {errors in while loops} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
} {1 {cannot use non-numeric string "a" as left operand of "+"}}
test while-old-4.5 {errors in while loops} {
catch {unset x}
set x 1
set err [catch {while {$x} {set x foo}} msg]
list $err $msg
} {1 {expected boolean value but got "foo"}}
test while-old-4.6 {errors in while loops} {
|
| ︙ | ︙ |
Changes to tests/while.test.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
catch {while {$i<} break}
return $::errorInfo
} -cleanup {
unset i
} -match glob -result {*"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} -body {
while {"a"+"b"} {error "loop aborted"}
| | | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
catch {while {$i<} break}
return $::errorInfo
} -cleanup {
unset i
} -match glob -result {*"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} -body {
while {"a"+"b"} {error "loop aborted"}
} -returnCodes error -result {cannot use non-numeric string "a" as left operand of "+"}
test while-1.4 {TclCompileWhileCmd: multiline test expr} -body {
set value 1
while {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
incr value
break
}
return $value
} -cleanup {
unset value
} -result {2}
test while-1.5 {TclCompileWhileCmd: non-numeric boolean test expr} -body {
set value 1
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
"set"*}
test while-1.9 {TclCompileWhileCmd: simple command body} -body {
set a {}
set i 1
while {$i<6} {
if {$i==4} break
set a [concat $a $i]
| | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
"set"*}
test while-1.9 {TclCompileWhileCmd: simple command body} -body {
set a {}
set i 1
while {$i<6} {
if {$i==4} break
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i
} -result {1 2 3}
test while-1.10 {TclCompileWhileCmd: command body in quotes} -body {
set a {}
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
| | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i
} -result {1 2 3}
test while-1.13 {TclCompileWhileCmd: while command result} -body {
set i 0
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
# Check "while" and "continue".
test while-2.1 {continue tests} -body {
set a {}
set i 1
while {$i <= 4} {
| | | | | | | | | | 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 |
# Check "while" and "continue".
test while-2.1 {continue tests} -body {
set a {}
set i 1
while {$i <= 4} {
incr i
if {$i == 3} continue
set a [concat $a $i]
}
return $a
} -cleanup {
unset a i
} -result {2 4 5}
test while-2.2 {continue tests} -body {
set a {}
set i 1
while {$i <= 4} {
incr i
if {$i != 2} continue
set a [concat $a $i]
}
return $a
} -cleanup {
unset a i
} -result {2}
test while-2.3 {continue tests, nested loops} -body {
set msg {}
set i 1
while {$i <= 4} {
incr i
set a 1
while {$a <= 2} {
incr a
if {$i>=3 && $a>=3} continue
set msg [concat $msg "$i.$a"]
}
}
return $msg
} -cleanup {
unset a i msg
} -result {2.2 2.3 3.2 4.2 5.2}
test while-2.4 {continue tests, long command body} -body {
set a {}
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
| | | | | | | | | | 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 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i
} -result {1 3}
# Check "while" and "break".
test while-3.1 {break tests} -body {
set a {}
set i 1
while {$i <= 4} {
if {$i == 3} break
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i
} -result {1 2}
test while-3.2 {break tests, nested loops} -body {
set msg {}
set i 1
while {$i <= 4} {
set a 1
while {$a <= 2} {
if {$i>=2 && $a>=2} break
set msg [concat $msg "$i.$a"]
incr a
}
incr i
}
return $msg
} -cleanup {
unset a i msg
} -result {1.1 1.2 2.1 3.1 4.1}
test while-3.3 {break tests, long command body} -body {
set a {}
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
| | | | 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 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i
} -result {1 3}
# Check "while" with computed command names.
test while-4.1 {while and computed command names} -body {
set i 0
set z while
$z {$i < 10} {
incr i
}
return $i
} -cleanup {
unset i z
} -result 10
test while-4.2 {while (not compiled): missing test expression} -body {
set z while
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
return $::errorInfo
} -match glob -cleanup {
unset i z
} -result {*"$z {$i<} {set x 1}"}
test while-4.4 {while (not compiled): error in test expression} -body {
set z while
$z {"a"+"b"} {error "loop aborted"}
| | | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
return $::errorInfo
} -match glob -cleanup {
unset i z
} -result {*"$z {$i<} {set x 1}"}
test while-4.4 {while (not compiled): error in test expression} -body {
set z while
$z {"a"+"b"} {error "loop aborted"}
} -returnCodes error -result {cannot use non-numeric string "a" as left operand of "+"}
test while-4.5 {while (not compiled): multiline test expr} -body {
set value 1
set z while
$z {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
incr value
break
}
return $value
} -cleanup {
unset value z
} -result {2}
test while-4.6 {while (not compiled): non-numeric boolean test expr} -body {
set value 1
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
test while-4.10 {while (not compiled): simple command body} -body {
set a {}
set i 1
set z while
$z {$i<6} {
if {$i==4} break
set a [concat $a $i]
| | | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
test while-4.10 {while (not compiled): simple command body} -body {
set a {}
set i 1
set z while
$z {$i<6} {
if {$i==4} break
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i z
} -result {1 2 3}
test while-4.11 {while (not compiled): command body in quotes} -body {
set a {}
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
| | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i z
} -result {1 2 3}
test while-4.14 {while (not compiled): while command result} -body {
set i 0
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 |
# Check "break" with computed command names.
test while-5.1 {break and computed command names} -body {
set i 0
set z break
while 1 {
| | | | | | | | | | | 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 |
# Check "break" with computed command names.
test while-5.1 {break and computed command names} -body {
set i 0
set z break
while 1 {
if {$i > 10} $z
incr i
}
return $i
} -cleanup {
unset i z
} -result 11
test while-5.2 {break tests with computed command names} -body {
set a {}
set i 1
set z break
while {$i <= 4} {
if {$i == 3} $z
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i z
} -result {1 2}
test while-5.3 {break tests, nested loops with computed command names} -body {
set msg {}
set i 1
set z break
while {$i <= 4} {
set a 1
while {$a <= 2} {
if {$i>=2 && $a>=2} $z
set msg [concat $msg "$i.$a"]
incr a
}
incr i
}
return $msg
} -cleanup {
unset a i z msg
} -result {1.1 1.2 2.1 3.1 4.1}
test while-5.4 {break tests, long command body with computed command names} -body {
set a {}
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
| | | | | | | | | | | | | | 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 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i z
} -result {1 3}
# Check "continue" with computed command names.
test while-6.1 {continue and computed command names} -body {
set i 0
set z continue
while 1 {
incr i
if {$i < 10} $z
break
}
return $i
} -cleanup {
unset i z
} -result 10
test while-6.2 {continue tests} -body {
set a {}
set i 1
set z continue
while {$i <= 4} {
incr i
if {$i == 3} $z
set a [concat $a $i]
}
return $a
} -cleanup {
unset a i z
} -result {2 4 5}
test while-6.3 {continue tests with computed command names} -body {
set a {}
set i 1
set z continue
while {$i <= 4} {
incr i
if {$i != 2} $z
set a [concat $a $i]
}
return $a
} -cleanup {
unset a i z
} -result {2}
test while-6.4 {continue tests, nested loops with computed command names} -body {
set msg {}
set i 1
set z continue
while {$i <= 4} {
incr i
set a 1
while {$a <= 2} {
incr a
if {$i>=3 && $a>=3} $z
set msg [concat $msg "$i.$a"]
}
}
return $msg
} -cleanup {
unset a i z msg
} -result {2.2 2.3 3.2 4.2 5.2}
test while-6.5 {continue tests, long command body with computed command names} -body {
set a {}
|
| ︙ | ︙ | |||
662 663 664 665 666 667 668 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
| | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
incr i
}
return $a
} -cleanup {
unset a i z
} -result {1 3}
# Test for incorrect "double evaluation" semantics
|
| ︙ | ︙ |
Changes to tests/winConsole.test.
1 2 3 4 5 6 | # This file tests the tclWinConsole.c file. # # 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. # | | > < | | | | | | | 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 |
# This file tests the tclWinConsole.c file.
#
# 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.
#
# NOTE THIS CANNOT BE RUN VIA nmake/make test since stdin is connected to
# nmake in that case.
#
# 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::*
}
catch {package require twapi} ;# Only to bring window to foreground. Not critical
::tcltest::ConstraintInitializer haveThread { expr {![catch {package require Thread}]} }
# Prompt user for a yes/no response
proc yesno {question {default "Y"}} {
set answer ""
# Make sure we are seen but catch because ui and console
# packages may not be available
catch {twapi::set_foreground_window [twapi::get_console_window]}
while {![string is boolean -strict $answer]} {
puts -nonewline stdout "$question Type Y/N followed by Enter \[$default\] : "
flush stdout
set answer [string trim [gets stdin]]
if {$answer eq ""} {
set answer $default
}
}
return [expr {!! $answer}]
}
proc prompt {prompt} {
# Make sure we are seen but catch because twapi ui and console
# packages may not be available
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
} -body {
set oldmode [fconfigure stdin]
prompt "Type \"abc\" and hit Enter: "
fileevent stdin readable {
if {[gets stdin line] >= 0} {
lappend result2 $line
| | | | | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
} -body {
set oldmode [fconfigure stdin]
prompt "Type \"abc\" and hit Enter: "
fileevent stdin readable {
if {[gets stdin line] >= 0} {
lappend result2 $line
if {[llength $result2] > 1} {
set result $result2
} else {
prompt "Type \"def\" and hit Enter: "
}
} elseif {[eof stdin]} {
set result "gets failed"
}
}
fconfigure stdin -blocking 0 -buffering line
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
unset -nocomplain result
unset -nocomplain result2
} -body {
prompt "Type \"abc\" and hit Enter: "
fileevent stdin readable {
if {[gets stdin line] >= 0} {
lappend result2 $line
| | | | | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
unset -nocomplain result
unset -nocomplain result2
} -body {
prompt "Type \"abc\" and hit Enter: "
fileevent stdin readable {
if {[gets stdin line] >= 0} {
lappend result2 $line
if {[llength $result2] > 1} {
set result $result2
} else {
prompt "Type \"def\" and hit Enter: "
}
} elseif {[eof stdin]} {
set result "gets failed"
}
}
vwait result
|
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
puts ""; # Because CRLF also would not have been echoed
} -body {
set input ""
fconfigure stdin -blocking 0 -buffering line -inputmode raw
prompt "Type \"abc\". Do NOT hit Enter. You will NOT see characters echoed."
fileevent stdin readable {
| | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | 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 |
puts ""; # Because CRLF also would not have been echoed
} -body {
set input ""
fconfigure stdin -blocking 0 -buffering line -inputmode raw
prompt "Type \"abc\". Do NOT hit Enter. You will NOT see characters echoed."
fileevent stdin readable {
set c [read stdin 1]
if {$c eq ""} {
if {[eof stdin]} {
set result "read eof"
}
} else {
append input $c
if {[string length $input] == 3} {
set result $input
}
}
}
set result {}
vwait result
fileevent stdin readable {}
set result
} -result abc
test console-input-3.0 {Console gets blocking - long lines bug-bda99f2393} -constraints {
win interactive
} -body {
prompt "Try typing a line of at least 256 characters. Hit ENTER exactly once unless you don't see another prompt.\n"
gets stdin line
set len [string length $line]
list [yesno "Did you hit ENTER only once?"] [expr {$len > 256}] [yesno "Line length was $len characters. Is this correct?"]
} -result {1 1 1}
test console-input-3.1 {Console gets blocking, small channel buffer size - long lines bug-bda99f2393} -constraints {
win interactive
} -body {
prompt "Try typing a line of at least 256 characters. Hit ENTER exactly once unless you don't see another prompt.\n"
set bufSize [fconfigure stdin -buffersize]
fconfigure stdin -buffersize 10
gets stdin line
fconfigure stdin -buffersize $bufSize
set len [string length $line]
list [yesno "Did you hit ENTER only once?"] [expr {$len > 256}] [yesno "Line length was $len characters. Is this correct?"]
} -result {1 1 1}
test console-input-3.2 {Console gets nonblocking - long lines bug-bda99f2393} -constraints {
win interactive
} -body {
prompt "Try typing a line of at least 256 characters. Hit ENTER exactly once unless you don't see another prompt.\n"
fconfigure stdin -blocking 0
while {[gets stdin line] < 0} {
after 1000
}
fconfigure stdin -blocking 1
set len [string length $line]
list [yesno "Did you hit ENTER only once?"] [expr {$len > 256}] [yesno "Line length was $len characters. Is this correct?"]
} -result {1 1 1}
test console-input-3.3 {Console gets nonblocking small channel buffer size - long lines bug-bda99f2393} -constraints {
win interactive
} -body {
prompt "Try typing a line of at least 256 characters. Hit ENTER exactly once unless you don't see another prompt.\n"
set bufSize [fconfigure stdin -buffersize]
fconfigure stdin -blocking 0 -buffersize 10
while {[gets stdin line] < 0} {
after 1000
}
fconfigure stdin -blocking 1 -buffersize $bufSize
set len [string length $line]
list [yesno "Did you hit ENTER only once?"] [expr {$len > 256}] [yesno "Line length was $len characters. Is this correct?"]
} -result {1 1 1}
# Output tests
test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body {
puts stdout "123"
yesno "Did you see the string \"123\"?"
} -result 1
test console-output-1.1 {Console non-blocking puts stdout} -constraints {
win interactive
} -setup {
set oldmode [fconfigure stdout]
dict unset oldmode -winsize
} -cleanup {
fconfigure stdout {*}$oldmode
} -body {
fconfigure stdout -blocking 0 -buffering line
set count 0
fileevent stdout writable {
if {[incr count] < 4} {
puts "$count"
} else {
fileevent stdout writable {}
set done 1
}
}
vwait done
yesno "Did you see 1, 2, 3 printed on consecutive lines?"
} -result 1
test console-output-2.0 {Console blocking puts stderr} -constraints {win interactive} -body {
puts stderr "456"
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
-buffering line
-buffersize 4096
-encoding utf-16
-inputmode normal
-translation auto
} {
test console-fconfigure-get-1.[incr testnum] "Console get stdin option $opt" \
| | | | | | | | | | | | | | | | | | | | | 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 |
-buffering line
-buffersize 4096
-encoding utf-16
-inputmode normal
-translation auto
} {
test console-fconfigure-get-1.[incr testnum] "Console get stdin option $opt" \
-constraints {win interactive} -body {
fconfigure stdin $opt
} -result $result
}
test console-fconfigure-get-1.[incr testnum] {
Console get stdin option -eofchar
} -constraints {win interactive} -body {
fconfigure stdin -eofchar
} -result ""
test console-fconfigure-get-1.[incr testnum] {
fconfigure -winsize
} -constraints {win interactive} -body {
fconfigure stdin -winsize
} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, -translation, or -inputmode} -returnCodes error
## fconfigure get stdout/stderr
foreach chan {stdout stderr} major {2 3} {
test console-fconfigure-get-$major.0 "Console get $chan configuration" -constraints {
win interactive
} -body {
lsort [dict keys [fconfigure $chan]]
} -result {-blocking -buffering -buffersize -encoding -eofchar -profile -translation -winsize}
set testnum 0
foreach {opt result} {
-blocking 1
-buffersize 4096
-encoding utf-16
-translation crlf
} {
test console-fconfigure-get-$major.[incr testnum] "Console get $chan option $opt" \
-constraints {win interactive} -body {
fconfigure $chan $opt
} -result $result
}
test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" \
-constraints {win interactive} -body {
fconfigure $chan -winsize
} -result {\d+ \d+} -match regexp
test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" \
-constraints {win interactive} -body {
fconfigure $chan -buffering
} -result [expr {$chan eq "stdout" ? "line" : "none"}]
test console-fconfigure-get-$major.[incr testnum] {
fconfigure -inputmode
} -constraints {win interactive} -body {
fconfigure $chan -inputmode
} -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, -translation, or -winsize} -returnCodes error
}
## fconfigure set stdin
test console-fconfigure-set-1.0 {
|
| ︙ | ︙ |
Changes to tests/winDde.test.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
file delete -force $::scriptName
set f [open $::scriptName w+]
fconfigure $f -encoding utf-8
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib Dde]
puts $f {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
file delete -force $::scriptName
set f [open $::scriptName w+]
fconfigure $f -encoding utf-8
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib Dde]
puts $f {
# DDE child server -
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# If an error occurs during the tests, this process may end up not
# being closed down. To deal with this we create a 30s timeout.
proc ::DoTimeout {} {
global done ddeServerName
set done 1
puts "winDde.test child process $ddeServerName timed out."
flush stdout
}
set timeout [after 30000 ::DoTimeout]
# Define a restricted handler.
proc Handler1 {cmd} {
if {$cmd eq "stop"} {set ::done 1}
if {$cmd == ""} {
set cmd "null data"
}
puts $cmd ; flush stdout
return
}
proc Handler2 {cmd} {
if {$cmd eq "stop"} {set ::done 1}
puts [uplevel \#0 $cmd] ; flush stdout
return
}
proc Handler3 {prefix cmd} {
if {$cmd eq "stop"} {set ::done 1}
puts [list $prefix $cmd] ; flush stdout
return
}
}
# set the dde server name to the supplied argument.
puts $f [list dde servername {*}$args -- $ddeServerName]
puts $f {
# run the server and handle final cleanup.
after 200;# give dde a chance to get going.
puts ready
flush stdout
vwait done
# allow enough time for the calling process to
# claim all results, to avoid spurious "server did
# not respond"
after 200 {set reallyDone 1}
vwait reallyDone
exit
|
| ︙ | ︙ |
Changes to tests/winFCmd.test.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
}
proc cleanupRecurse {args} {
# Assumes no loops via links!
# Need to change permissions BEFORE deletion
catch {testchmod 0o777 {*}$args}
foreach victim $args {
| | | | | | | | | | 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 |
}
proc cleanupRecurse {args} {
# Assumes no loops via links!
# Need to change permissions BEFORE deletion
catch {testchmod 0o777 {*}$args}
foreach victim $args {
if {[file isdirectory $victim]} {
cleanupRecurse {*}[glob -nocomplain -directory $victim td* tf* Test*]
}
file delete -force $victim
}
}
proc cleanup {args} {
foreach p [list [pwd] {*}$args] {
cleanupRecurse {*}[glob -nocomplain -directory $p tf* td*]
}
}
# find a CD-ROM so we can test read-only filesystems.
proc findfile {dir} {
foreach p [glob -nocomplain -type f -directory $dir *] {
return $p
}
foreach p [glob -nocomplain -type d -directory $dir *] {
set f [findfile $p]
if {$f ne ""} {
return $f
}
}
return ""
}
if {[testConstraint testvolumetype]} {
foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
if {![catch {testvolumetype ${p}:} result] && $result in {CDFS UDF}} {
set cdrom ${p}:
set cdfile [findfile $cdrom]
testConstraint cdrom 1
break
}
}
}
# NB: filename is chosen to be short but unlikely to clash with other apps
if {[file exists c:/] && [file exists d:/]} {
catch {file delete d:/TclTmpF.1}
catch {file delete d:/TclTmpD.1}
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 |
expr {$statExe(ino) != 0}
}]
proc MakeFiles {dirname} {
set inodes {}
set ndx -1
while {1} {
| | | | | | | | | | | | | | | | 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 |
expr {$statExe(ino) != 0}
}]
proc MakeFiles {dirname} {
set inodes {}
set ndx -1
while {1} {
# upped to 50K for 64bit Server 2008
if {$ndx > 50000} {
tcltest::Skip "limit-reached:no-collistion"
}
set filename [file join $dirname Test[incr ndx]]
set f [open $filename w]
close $f
file stat $filename stat
if {[set n [lsearch -exact -integer $inodes $stat(ino)]] >= 0} {
return [list [file join $dirname Test$n] $filename]
}
lappend inodes $stat(ino)
unset stat
}
}
test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup {
cleanup
} -constraints {win winNonZeroInodes knownMsvcBug notInCIenv extensive} -body {
file mkdir td1
lassign [MakeFiles td1] a b
file rename -force $a $b
file exists $a
} -cleanup {
cleanup
} -result 0
|
| ︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 |
}
# Old versions of Tcl gave a misleading error that the
# directory in question didn't exist.
if {[llength $d] && [catch {cd [lindex $d 0]} err]} {
regsub ".*: " $err "" err
set err
} else {
| | | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
}
# Old versions of Tcl gave a misleading error that the
# directory in question didn't exist.
if {[llength $d] && [catch {cd [lindex $d 0]} err]} {
regsub ".*: " $err "" err
set err
} else {
set err "permission denied"
}
} -cleanup {
cd $pwd
} -result "permission denied"
cd $pwd
unset d dd pwd
|
| ︙ | ︙ | |||
1327 1328 1329 1330 1331 1332 1333 |
file normalize //?/c:/windows/../windows/win.ini
} -result //?/c:/windows/win.ini
test winFCmd-19.3 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
set tmpfile [file normalize $tmpfile]
} -body {
list [catch {
| | | | | | | | | | | | | | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 |
file normalize //?/c:/windows/../windows/win.ini
} -result //?/c:/windows/win.ini
test winFCmd-19.3 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
set tmpfile [file normalize $tmpfile]
} -body {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
} res] $res
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
test winFCmd-19.4 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
set tmpfile //?/[file normalize $tmpfile]
} -body {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
} res] $res
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
test winFCmd-19.5 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile [file normalize $tmpfile]
} -body {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
} res] $res
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
test winFCmd-19.6 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile //?/[file normalize $tmpfile]
} -body {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
} res] $res
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
test winFCmd-19.7 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
set tmpfile [file normalize $tmpfile]
} -body {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
} res] $res [glob -directory $::env(TEMP) -tails tcl[pid].*]
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {} [list tcl[pid].tmp]]
test winFCmd-19.8 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
set tmpfile //?/[file normalize $tmpfile]
} -body {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
} res] $res [glob -directory $::env(TEMP) -tails tcl[pid].*]
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {} [list "tcl[pid].tmp "]]
test winFCmd-19.9 {Windows devices path names} -constraints win -body {
file normalize //./com1
|
| ︙ | ︙ |
Changes to tests/winFile.test.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
set tryname $fname
if {[file isdirectory $fname]} {
set tryname [file dirname $fname]
}
set owner ""
set tail [file tail $tryname]
if {[info exists env(OSTYPE)] && $env(OSTYPE) eq "msys"} {
| | | | | | | | | | | | | | 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 |
set tryname $fname
if {[file isdirectory $fname]} {
set tryname [file dirname $fname]
}
set owner ""
set tail [file tail $tryname]
if {[info exists env(OSTYPE)] && $env(OSTYPE) eq "msys"} {
set dirtext [exec ls -l $fname]
foreach line [split $dirtext "\n"] {
set owner [lindex $line 2]
}
} else {
set dirtext [exec cmd /c dir /q [file nativename $fname]]
foreach line [split $dirtext "\n"] {
if {[string match -nocase "*$tail" $line]} {
set attrs [string range $line 0 end-[string length $tail]]
regexp { [^ \\]+\\.*$} $attrs owner
set owner [string trim $owner]
}
}
}
if {$owner eq ""} {
error "getuser: Owner not found in output of dir/q"
}
return $owner
}
|
| ︙ | ︙ |
Changes to tests/winTime.test.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
set failed {}
set ok 1
foreach start_sec [testwinclock] break
while { 1 } {
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
set diff [expr { $tcl_sec - $sys_sec
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
| | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
set failed {}
set ok 1
foreach start_sec [testwinclock] break
while { 1 } {
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
set diff [expr { $tcl_sec - $sys_sec
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
if { abs($diff) > 0.1 } {
set failed "Tcl clock differs from system clock by $diff sec"
break
} else {
testwinsleep 1
}
if { $sys_sec - $start_sec >= 30 } break
}
|
| ︙ | ︙ |
Changes to tests/zipfs.test.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | set ziproot [zipfs root] set CWD [pwd] set tmpdir [file join $CWD tmp] file mkdir $tmpdir | < < < | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
set ziproot [zipfs root]
set CWD [pwd]
set tmpdir [file join $CWD tmp]
file mkdir $tmpdir
test zipfs-0.1 {zipfs basics} -constraints zipfs -body {
expr {${ziproot} in [file volumes]}
} -result 1
if {[string match ${ziproot}* $tcl_library]} {
testConstraint zipfslib 1
set zipLibTop [file tail [file join {*}[lrange [file split $tcl_library] 0 1]]]
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body {
cd $tcl_library/encoding
zipfs mkzip $zipfile .
set fin [open $zipfile r]
fconfigure $fin -translation binary
set dat [read $fin]
close $fin
| | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body {
cd $tcl_library/encoding
zipfs mkzip $zipfile .
set fin [open $zipfile r]
fconfigure $fin -translation binary
set dat [read $fin]
close $fin
zipfs mountdata $dat def
zipfs list -glob ${ziproot}def/cp850.*
} -cleanup {
cd $CWD
} -result "${ziproot}def/cp850.enc"
testConstraint zipfsencbuf [zipfs exists ${ziproot}def/cp850.enc]
test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body {
set r [zipfs info ${ziproot}def/cp850.enc]
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 |
set interp [interp create]
} -body {
interp eval $interp {
zipfs ?
}
} -returnCodes error -cleanup {
interp delete $interp
| | > | | | | | 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 |
set interp [interp create]
} -body {
interp eval $interp {
zipfs ?
}
} -returnCodes error -cleanup {
interp delete $interp
} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mountdata, root, or unmount}
test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup {
set interp [interp create]
} -body {
interp eval $interp {
zipfs mkzip
}
} -returnCodes error -cleanup {
interp delete $interp
} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"}
test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup {
set safe [interp create -safe]
} -body {
interp eval $safe {
zipfs ?
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {invalid command name "zipfs"}
test zipfs-3.4 {zipfs in safe interpreters} -constraints zipfs -setup {
set safe [interp create -safe]
} -body {
interp eval $safe {
zipfs
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {invalid command name "zipfs"}
test zipfs-4.1 {zipfs lmkimg} -constraints zipfs -setup {
set baseImage [makeFile "return sourceWorking\n\x1A" base]
set targetImage [makeFile "" target]
set addFile [makeFile "return mountWorking" add.data]
file delete $targetImage
} -body {
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
zipfs unmount ziptest
removeFile $baseImage
removeFile $midImage
removeFile $targetImage
removeFile $addFile
} -result [list ${ziproot}/ziptest/test/add.tcl ${ziproot}/ziptest/test/ok.tcl]
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > | | | | | | 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 |
zipfs unmount ziptest
removeFile $baseImage
removeFile $midImage
removeFile $targetImage
removeFile $addFile
} -result [list ${ziproot}/ziptest/test/add.tcl ${ziproot}/ziptest/test/ok.tcl]
test zipfs-5.1 {zipfs mountdata: short data} -constraints zipfs -body {
zipfs mountdata {} gorp
} -returnCodes error -result {illegal file size}
test zipfs-5.2 {zipfs mountdata: short data} -constraints zipfs -body {
zipfs mountdata gorpGORPgorp gorp
} -returnCodes error -result {illegal file size}
test zipfs-5.3 {zipfs mountdata: short data} -constraints zipfs -body {
set data PK\x03\x04.....................................
append data PK\x01\x02.....................................
append data PK\x05\x06.....................................
zipfs mountdata $data gorp
} -returnCodes error -result {archive directory truncated}
test zipfs-6.1 {zipfs mkkey} -constraints zipfs -body {
binary scan [zipfs mkkey gorp] cu* x
return $x
} -result {224 226 111 103 4 80 75 90 90}
#
# Additional tests for more coverage. Some of the ones above may be duplicated.
namespace eval test_ns_zipfs {
namespace import ::tcltest::test
namespace path ::tcltests
variable zipTestDir [file normalize [file join [file dirname [info script]] zipfiles]]
variable defMountPt [file join [zipfs root] testmount]
proc readbin {path} {
set fd [open $path rb]
set data [read $fd]
close $fd
return $data
}
# Wrapper to ease transition if Tcl changes order of argument to zipfs mount
# or the zipfs prefix
proc mount [list zippath [list mountpoint $defMountPt]] {
return [zipfs mount $zippath $mountpoint]
}
# Make full path to zip file
proc zippath {zippath} {
variable zipTestDir
if {[file pathtype $zippath] eq "absolute"} {
return $zippath
} else {
return [file join $zipTestDir $zippath]
}
}
# list of paths -> list of paths under mount point mt
proc zipfspathsmt {mt args} {
return [lsort [lmap path $args {file join $mt $path}]]
}
# list of paths -> list of paths under [zipfs root]
proc zipfspaths {args} {
return [zipfspathsmt [zipfs root] {*}$args]
}
proc cleanup {} {
dict for {mount -} [zipfs mount] {
if {[string match //zipfs:/test* $mount]} {
zipfs unmount $mount
}
}
zipfs unmount [zipfs root]
}
proc mounttarget {mountpoint} {
return [dict getdef [zipfs mount] $mountpoint ""]
}
#
# zipfs root - only arg count check since do not want to assume
# what it resolves to
testnumargs "zipfs root" "" ""
#
# zipfs mount
proc testbadmount {id zippath messagePattern args} {
variable defMountPt
set zippath [zippath $zippath]
test zipfs-mount-$id $id -body {
list [catch {mount $zippath} message] \
[string match $messagePattern $message] \
[mounttarget $defMountPt]
} -cleanup {
# In case mount succeeded when it should not
cleanup
} -result {1 1 {}} {*}$args
if {![file exists $zippath]} {
return
}
set data [readbin $zippath]
test zipfs-mountdata-$id $id -body {
list [catch {zipfs mountdata $data $defMountPt} message] \
[string match $messagePattern $message] \
[mounttarget $defMountPt]
} -cleanup {
# In case mount succeeded when it should not
cleanup
} -result {1 1 {}} {*}$args
}
# Generates tests for file, file on root, memory buffer cases for an archive
proc testmount {id zippath checkPath mountpoint args} {
set zippath [zippath $zippath]
test zipfs-mount-$id "zipfs mount $id" -body {
set canon [mount $zippath $mountpoint]
list [file exists [file join $canon $checkPath]] \
[zipfs mount $canon] [zipfs mount $mountpoint]
} -cleanup {
zipfs unmount $mountpoint
} -result [list 1 $zippath $zippath] {*}$args
# Mount memory buffer
test zipfs-mountdata-$id "zipfs mountdata $id" -body {
set canon [zipfs mountdata [readbin $zippath] $mountpoint]
list [file exists [file join $canon $checkPath]] \
[zipfs mount $canon] [zipfs mount $mountpoint]
} -cleanup {
cleanup
} -result [list 1 {Memory Buffer} {Memory Buffer}] {*}$args
}
testnumargs "zipfs mount" "" "?zipfile? ?mountpoint? ?password?"
testnumargs "zipfs mountdata" "data mountpoint" ""
# Not supported zip files
testbadmount non-existent-file nosuchfile.zip "couldn't open*nosuchfile.zip*no such file or directory"
testbadmount not-zipfile [file normalize [info script]] "archive directory end signature not found"
testbadmount zip64-unsupported zip64.zip "wrong header signature"
# Inconsistent metadata
testbadmount bad-directory-offset incons-cdoffset.zip "archive directory truncated"
testbadmount bad-directory-magic incons-central-magic-bad.zip "wrong header signature"
testbadmount bad-local-magic incons-local-magic-bad.zip "Failed to find local header"
testbadmount bad-file-count-high incons-file-count-high.zip "truncated directory"
testbadmount bad-file-count-low incons-file-count-low.zip "short file count"
test zipfs-mount-on-drive "Mount point include drive" -body {
zipfs mount [zippath test.zip] C:/foo
} -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win
test zipfs-mountdata-on-drive "Mount point include drive" -body {
zipfs mountdata [readbin [zippath test.zip]] C:/foo
} -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win
test zipfs-mount-on-unc "Mount point is unc" -body {
zipfs mount [zippath test.zip] //unc/share/foo
} -result {Invalid mount path "//unc/share/foo"} -returnCodes error
test zipfs-mountdata-on-unc "Mount point include unc" -body {
zipfs mountdata [readbin [zippath test.zip]] //unc/share/foo
} -result {Invalid mount path "//unc/share/foo"} -returnCodes error
# Good mounts
testmount basic test.zip testdir/test2 $defMountPt
testmount basic-on-default test.zip testdir/test2 ""
testmount basic-on-root test.zip testdir/test2 [zipfs root]
testmount basic-on-slash test.zip testdir/test2 /
testmount basic-on-bslash test.zip testdir/test2 \\ -constraints win
testmount basic-on-relative test.zip testdir/test2 testmount
testmount basic-on-absolute test.zip testdir/test2 /testmount
testmount basic-on-absolute-bslash test.zip testdir/test2 \\testmount -constraints win
testmount zip-at-end junk-at-start.zip testdir/test2 $defMountPt
testmount zip-at-start junk-at-end.zip testdir/test2 $defMountPt
testmount zip-in-zip [file join [zipfs root] test2 test.zip] testdir/test2 $defMountPt -setup {
mount [zippath test-zip-in-zip.zip] [file join [zipfs root] test2]
} -cleanup {
zipfs unmount $mountpoint
zipfs unmount [file join [zipfs root] test2]
}
testmount relative-mount-point test.zip testdir/test2 ""
test zipfs-mount-busy-1 "Attempt to mount on existing mount point" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
zipfs mount [zippath testfile-cp437.zip] $defMountPt
} -result "[zippath test.zip] is already mounted on $defMountPt" -returnCodes error
test zipfs-mount-no-args-1 "mount - get mount list" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set mounts [zipfs mount]
lsearch -inline -stride 2 $mounts $defMountPt
} -result [list $defMountPt [zippath test.zip]]
test zipfs-mount-one-arg-1 "mount - get mount target - absolute path" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
zipfs mount $defMountPt
} -result [zippath test.zip]
test zipfs-mount-one-arg-2 "mount - get mount target - relative path" -setup {
file copy [zippath test.zip] test.zip
mount ./test.zip
} -cleanup {
cleanup
file delete ./test.zip
} -body {
zipfs mount $defMountPt
} -result [file normalize ./test.zip]
test zipfs-mount-password-1 "mount - verify plaintext readable without password" -body {
zipfs mount [zippath test-password.zip] $defMountPt
readbin [file join $defMountPt plain.txt]
} -cleanup {
cleanup
} -result plaintext
test zipfs-mount-password-2 "mount - verify uncompressed cipher unreadable without password" -body {
zipfs mount [zippath test-password.zip] $defMountPt
set chans [lsort [chan names]]; # Want to ensure open does not leave dangling channel
set result [list ]
lappend result [catch {open [file join $defMountPt cipher.bin]} message]
lappend result $message
lappend result [string equal $chans [lsort [chan names]]]
} -cleanup {
cleanup
} -result {1 {decryption failed - no password provided} 1}
test zipfs-mount-password-3 "mount - verify compressed cipher unreadable without password" -body {
zipfs mount [zippath test-password.zip] $defMountPt
set chans [lsort [chan names]]; # Want to ensure open does not leave dangling channel
set result [list ]
lappend result [catch {open [file join $defMountPt cipher-deflate.bin]} message]
lappend result $message
lappend result [string equal $chans [lsort [chan names]]]
} -cleanup {
cleanup
} -result {1 {decryption failed - no password provided} 1}
test zipfs-mount-nested-1 "mount - nested mount on non-existing path" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set newmount [file join $defMountPt newdir]
mount [zippath test-overlay.zip] $newmount
list \
[lsort [glob -tails -dir $defMountPt *]] \
[lsort [glob -tails -dir $newmount *]] \
[readbin [file join $newmount test2]]
} -result {{newdir test testdir} {test2 test3} test2-overlay}
test zipfs-mount-nested-2 "mount - nested mount on existing path" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set newmount [file join $defMountPt testdir]
mount [zippath test-overlay.zip] $newmount
# Note - file from existing mount is preserved (testdir/test2)
# Not clear this is desired but defined as such by the
# current implementation
list \
[lsort [glob -tails -dir $defMountPt *]] \
[lsort [glob -tails -dir $newmount *]] \
[readbin [file join $newmount test2]]
} -result [list {test testdir} {test2 test3} test\n]
#
# unmount - only special cases. Normal case already tested as part of other tests
testnumargs "zipfs unmount" "mountpoint" ""
test zipfs-unmount-1 "Unmount bogus mount" -body {
zipfs unmount [file join [zipfs root] nosuchmount]
} -result ""
test zipfs-unmount-2 "Unmount mount with open files" -setup {
mount [zippath test.zip]
set fd [open [file join $defMountPt test]]
} -cleanup {
close $fd
cleanup
} -body {
zipfs unmount $defMountPt
} -result {filesystem is busy} -returnCodes error
test zipfs-unmount-3 "Unmount mount with current directory" -setup {
set cwd [pwd]
mount [zippath test.zip]
} -cleanup {
cd $cwd
cleanup
} -body {
# Current directory does not change on unmount.
# This is the same behavior as when USB pen drive is unmounted
set cwd2 [file join $defMountPt testdir]
cd $cwd2
list [pwd] [zipfs unmount $defMountPt] [string equal [pwd] $cwd2]
} -result [list [file join $defMountPt testdir] {} 1]
test zipfs-unmount-nested-1 "unmount parent of nested mount on new directory should not affect nested mount" -setup {
mount [zippath test.zip]
set newmount [file join [zipfs root] test newdir]
mount [zippath test-overlay.zip] $newmount
} -cleanup {
cleanup
} -body {
zipfs unmount $defMountPt
list \
[zipfs mount $defMountPt] \
[lsort [glob -tails -dir $newmount *]] \
[readbin [file join $newmount test2]]
} -result {{} {test2 test3} test2-overlay}
test zipfs-unmount-nested-2 "unmount parent of nested mount on existing directory should not affect nested mount" -setup {
mount [zippath test.zip]
set newmount [file join [zipfs root] test testdir]
mount [zippath test-overlay.zip] $newmount
} -constraints bug-4ae42446ab -cleanup {
cleanup
} -body {
# KNOWN BUG. The test2 file is also present in parent mount.
# After the unmount, the test2 in the nested mount is not
# made available.
zipfs unmount $defMountPt
list \
[zipfs mount $defMountPt] \
[lsort [glob -tails -dir $newmount *]] \
[readbin [file join $newmount test2]]
} -result {{} {test2 test3} test2-overlay}
#
# paths inside a zip
# TODO - paths encoded in utf-8 vs fallback encoding
test zipfs-content-paths-1 "Test absolute and full paths" -setup {
mount [zippath test-paths.zip]
} -cleanup {
cleanup
} -body {
# Primarily verifies that drive letters are stripped and paths maintained
lsort [zipfs find $defMountPt]
} -result {//zipfs:/testmount/filename.txt //zipfs:/testmount/src //zipfs:/testmount/src/tcltk //zipfs:/testmount/src/tcltk/wip //zipfs:/testmount/src/tcltk/wip/tcl //zipfs:/testmount/src/tcltk/wip/tcl/tests //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles/abspath.txt //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles/fullpath.txt}
#
# zipfs list
testnumargs "zipfs list" "" "?(-glob|-regexp)? ?pattern?"
# Generates zipfs list tests for file, memory buffer cases for an archive
proc testzipfslist {id cmdargs mounts resultpaths args} {
set resultpaths [lmap path $resultpaths {
file join [zipfs root] $path
}]
set resultpaths [lsort $resultpaths]
test zipfs-list-$id "zipfs list $id" -body {
lsort [zipfs list {*}$cmdargs]
} -setup {
foreach {zippath mountpoint} $mounts {
zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint]
}
} -cleanup {
cleanup
} -result $resultpaths {*}$args
# Mount memory buffer
test zipfs-list-memory-$id "zipfs list memory $id" -body {
lsort [zipfs list {*}$cmdargs]
} -setup {
foreach {zippath mountpoint} $mounts {
zipfs mountdata [readbin [zippath $zippath]] [file join [zipfs root] $mountpoint]
}
} -cleanup {
cleanup
} -result $resultpaths {*}$args
}
# Some tests have !zipfslib constraint because otherwise they dump the entire Tcl library which is mounted on root
testzipfslist no-mounts "" {} {} -constraints !zipfslib
testzipfslist no-pattern "" {test.zip testmountA} {testmountA testmountA/test testmountA/testdir testmountA/testdir/test2} -constraints !zipfslib
testzipfslist no-pattern-mount-on-empty "" {test.zip {}} {{} test testdir testdir/test2} -constraints !zipfslib
testzipfslist no-pattern-mount-on-root "" [list test.zip [zipfs root]] {{} test testdir testdir/test2} -constraints !zipfslib
testzipfslist no-pattern-mount-on-slash "" [list test.zip /] {{} test testdir testdir/test2} -constraints !zipfslib
testzipfslist no-pattern-mount-on-mezzo "" [list test.zip testmt/a/b] {testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2} -constraints {!zipfslib}
testzipfslist no-pattern-multiple "" {test.zip testmountA test.zip testmountB/subdir} {
testmountA testmountA/test testmountA/testdir testmountA/testdir/test2
testmountB/subdir testmountB/subdir/test testmountB/subdir/testdir testmountB/subdir/testdir/test2
} -constraints !zipfslib
testzipfslist glob [list "*testmount*2*"] {test.zip testmountA test.zip testmountB/subdir} {
testmountA/testdir/test2
testmountB/subdir/testdir/test2
}
testzipfslist opt-glob [list -glob "*testmount*2*"] {test.zip testmountA test.zip testmountB/subdir} {
testmountA/testdir/test2
testmountB/subdir/testdir/test2
}
testzipfslist opt-regexp [list -regexp "testmount.*(A|2)"] {test.zip testmountA test.zip testmountB/subdir} {
testmountA testmountA/test testmountA/testdir testmountA/testdir/test2
testmountB/subdir/testdir/test2
}
#
# zipfs exists
testnumargs "zipfs exists" "filename" ""
# Generates tests for zipfs exists
proc testzipfsexists [list id path result [list mountpoint $defMountPt] args] {
test zipfs-exists-$id "zipfs exists $id" -body {
zipfs exists $path
} -setup {
mount [zippath test.zip] $mountpoint
} -cleanup {
zipfs unmount $mountpoint
cleanup
} -result $result {*}$args
}
testzipfsexists native-file [info nameofexecutable] 0
testzipfsexists enoent [file join $defMountPt nosuchfile] 0
testzipfsexists file [file join $defMountPt test] 1
testzipfsexists dir [file join $defMountPt testdir] 1
testzipfsexists mountpoint $defMountPt 1
testzipfsexists root [zipfs root] 1 $defMountPt
testzipfsexists mezzo [file join $defMountPt a b] 1 [file join $defMountPt a b c]
testzipfsexists mezzo-enoent [file join $defMountPt a c] 0 [file join $defMountPt a b c]
#
# zipfs find
testnumargs "zipfs find" "directoryName" ""
# Generates zipfs find tests for file, memory buffer cases for an archive
proc testzipfsfind {id findtarget mounts resultpaths args} {
set setup {
foreach {zippath mountpoint} $mounts {
zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint]
}
}
set memory_setup {
foreach {zippath mountpoint} $mounts {
zipfs mountdata [readbin [zippath $zippath]] [file join [zipfs root] $mountpoint]
}
}
if {[dict exists $args -setup]} {
append setup \n[dict get $args -setup]
append memory_setup \n[dict get $args -setup]
dict unset args -setup
}
set cleanup cleanup
if {[dict exists $args -cleanup]} {
set cleanup "[dict get $args -cleanup]\n$cleanup"
dict unset args -cleanup
}
set resultpaths [lsort $resultpaths]
test zipfs-find-$id "zipfs find $id" -body {
lsort [zipfs find $findtarget]
} -setup $setup -cleanup $cleanup -result $resultpaths {*}$args
# Mount memory buffer
test zipfs-find-memory-$id "zipfs find memory $id" -body {
lsort [zipfs find $findtarget]
} -setup $memory_setup -cleanup $cleanup -result $resultpaths {*}$args
}
testzipfsfind nonexistingmount [file join [zipfs root] nosuchmount] {
test.zip testmountA test.zip testmountB/subdir
} {}
testzipfsfind absolute-path [file join [zipfs root] testmountA] {
test.zip testmountA test.zip testmountB/subdir
} [zipfspaths testmountA/test testmountA/testdir testmountA/testdir/test2]
testzipfsfind relative-path testdir {
test.zip testmountA test.zip testmountB/subdir
} { testdir/test2 } -setup {
set cwd [pwd]
cd [file join [zipfs root] testmountA]
} -cleanup {
cd $cwd
}
# bug-6183f535c8
testzipfsfind root-path [zipfs root] {
test.zip {} test.zip testmountB/subdir
} [zipfspaths test testdir testdir/test2 testmountB testmountB/subdir testmountB/subdir/test testmountB/subdir/testdir testmountB/subdir/testdir/test2] -constraints !zipfslib
testzipfsfind mezzo [file join [zipfs root] testmt a] {
test.zip testmt/a/b
} [zipfspaths testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2]
testzipfsfind mezzo-root [zipfs root] {
test.zip testmt/a/b
} [zipfspaths testmt testmt/a testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2] -constraints !zipfslib
test zipfs-find-native-absolute "zipfs find on native file system" -setup {
set dir [makeDirectory zipfs-native-absolute]
set subdir [file join $dir subdir]
file mkdir $subdir
set file [file join $subdir native]
close [open $file w]
} -cleanup {
removeDirectory zipfs-native-absolute
} -body {
string equal [zipfs find $dir] [list $subdir $file]
} -result 1
test zipfs-find-native-relative "zipfs find relative on native file system" -setup {
set dir [makeDirectory zipfs-native-relative]
set subdir [file join $dir subdir]
file mkdir $subdir
set file [file join $subdir native]
close [open $file w]
set cwd [pwd]
} -cleanup {
cd $cwd
removeDirectory zipfs-native-relative
} -body {
cd [file dirname $dir]
# string equal [zipfs find [file tail $subdir]] [list subdir subdir/native]
zipfs find [file tail $dir]
} -result {zipfs-native-relative/subdir zipfs-native-relative/subdir/native}
#
# zipfs info
testnumargs "zipfs info" "filename" ""
test zipfs-info-native-nosuchfile "zipfs info on non-existent native path" -body {
zipfs info nosuchfile
} -result {path "nosuchfile" not found in any zipfs volume} -returnCodes error
test zipfs-info-native-file "zipfs info on native path" -body {
zipfs info [info nameofexecutable]
} -result "path \"[info nameofexecutable]\" not found in any zipfs volume" -returnCodes error
test zipfs-info-nosuchfile "zipfs info non-existent path in mounted archive" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
zipfs info [file join $defMountPt nosuchfile]
} -result "path \"[file join $defMountPt nosuchfile]\" not found in any zipfs volume" -returnCodes error
test zipfs-info-file "zipfs info file within mounted archive" -setup {
mount [zippath testdeflated2.zip]
} -cleanup {
cleanup
} -body {
zipfs info [file join $defMountPt abac-repeat.txt]
} -result [list [zippath testdeflated2.zip] 60 17 108]
test zipfs-info-dir "zipfs info dir within mounted archive" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
zipfs info [file join $defMountPt testdir]
} -result [list [zippath test.zip] 0 0 119]
test zipfs-info-mountpoint "zipfs info on mount point - verify correct offset of zip content" -setup {
# zip starts at offset 4
mount [zippath junk-at-start.zip]
} -cleanup {
cleanup
} -body {
zipfs info $defMountPt
} -result [list [zippath junk-at-start.zip] 0 0 4]
test zipfs-info-mezzo "zipfs info on mount point - verify correct offset of zip content" -setup {
# zip starts at offset 4
mount [zippath junk-at-start.zip] /testmt/a/b
} -cleanup {
cleanup
} -body {
zipfs info [file join [zipfs root] testmt a]
} -result {path "//zipfs:/testmt/a" not found in any zipfs volume} -returnCodes error
test zipfs-info-tcllib-1 "zipfs info offset on tcl library" -constraints zipfslib -body {
expr {[lindex [zipfs info [file dirname $::tcl_library]] 3] > 0}
} -result 1
test zipfs-info-tcllib-2 "extract zip using zipfs info" -constraints zipfslib -cleanup {
cleanup
} -body {
set mt [file dirname $::tcl_library]
lassign [zipfs info $mt] container_path - - offset
set fd [open $container_path rb]
chan seek $fd $offset
set zipdata [read $fd]
zipfs mountdata $zipdata /testmt
list [expr {$offset > 0}] [file exists [file join [zipfs root] testmt tcl_library]]
} -result {1 1}
#
# zipfs canonical
test zipfs-canonical-minargs {zipfs canonical min args} -body {
zipfs canonical
} -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename"}
test zipfs-canonical-maxargs {zipfs canonical max args} -body {
zipfs canonical a b c
} -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename"}
proc testzipfscanonical {id cmdargs result args} {
test zipfs-canonical-$id "zipfs canonical $id" \
-body [list zipfs canonical {*}$cmdargs] \
-result $result {*}$args
}
testzipfscanonical default-relative [list a] [file join [zipfs root] a]
testzipfscanonical default-absolute [list /a] [file join [zipfs root] a]
testzipfscanonical root-relative-1 [list [zipfs root] a] [file join [zipfs root] a]
testzipfscanonical root-relative-2 [list / a] [file join [zipfs root] a]
testzipfscanonical root-absolute-1 [list [zipfs root] /a] [file join [zipfs root] a]
testzipfscanonical root-absolute-2 [list / /a] [file join [zipfs root] a]
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
testzipfscanonical backslashes-1 [list X:/foo\\\\bar] [file join [zipfs root] foo bar] -constraints win
testzipfscanonical zipfspath [list //zipfs:/x/y] [file join [zipfs root] x y]
testzipfscanonical zipfspath-1 [list MT //zipfs:/x/y] [file join [zipfs root] x y]
#
# Read/uncompress
proc testzipfsread {id zippath result {filename abac-repeat.txt} {openopts {}} args} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
testzipfscanonical backslashes-1 [list X:/foo\\\\bar] [file join [zipfs root] foo bar] -constraints win
testzipfscanonical zipfspath [list //zipfs:/x/y] [file join [zipfs root] x y]
testzipfscanonical zipfspath-1 [list MT //zipfs:/x/y] [file join [zipfs root] x y]
#
# Read/uncompress
proc testzipfsread {id zippath result {filename abac-repeat.txt} {openopts {}} args} {
variable defMountPt
set zippath [zippath $zippath]
test zipfs-read-$id "zipfs read $id" -setup {
unset -nocomplain fd
zipfs mount $zippath $defMountPt
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body {
set fd [open [file join $defMountPt $filename] {*}$openopts]
gets $fd
} -result $result {*}$args
set data [readbin $zippath]
test zipfs-read-memory-$id "zipfs read in-memory $id" -setup {
unset -nocomplain fd
zipfs mountdata $data $defMountPt
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body {
set fd [open [file join $defMountPt $filename] {*}$openopts]
gets $fd
} -result $result {*}$args
}
testzipfsread stored test.zip test test
testzipfsread stored-1 teststored.zip aaaaaaaaaaaaaa
testzipfsread deflate testdeflated2.zip aaaaaaaaaaaaaa
testzipfsread bug-23dd83ce7c empty.zip {} empty.txt
# Test open modes - see bug [4645658689]
|
| ︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 |
testzipfsread bzip2 testbzip2.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread lzma testfile-lzma.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread xz testfile-xz.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread zstd testfile-zstd.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread deflate-error broken.zip {decompression error} deflatezliberror {} -returnCodes error
test zipfs-read-unwritable "Writes not allowed on file opened for read" -setup {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
testzipfsread bzip2 testbzip2.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread lzma testfile-lzma.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread xz testfile-xz.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread zstd testfile-zstd.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
testzipfsread deflate-error broken.zip {decompression error} deflatezliberror {} -returnCodes error
test zipfs-read-unwritable "Writes not allowed on file opened for read" -setup {
mount [zippath test.zip]
} -cleanup {
close $fd
cleanup
} -body {
set fd [open [file join $defMountPt test]]
puts $fd blah
} -result {channel "*" wasn't opened for writing} -match glob -returnCodes error
#
# Write
proc testzipfswrite {id zippath result filename mode args} {
variable defMountPt
set zippath [zippath $zippath]
set path [file join $defMountPt $filename]
set body {
set fd [open $path $mode]
fconfigure $fd -translation binary
puts -nonewline $fd XYZ
seek $fd 0
puts -nonewline $fd xyz
close $fd
set fd [open $path]
fconfigure $fd -translation binary
read $fd
}
test zipfs-write-$id "zipfs write $id" -setup {
unset -nocomplain fd
zipfs mount $zippath $defMountPt
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body $body -result $result {*}$args
set data [readbin $zippath]
test zipfs-write-memory-$id "zipfs write in-memory $id" -setup {
unset -nocomplain fd
zipfs mountdata $data $defMountPt
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body $body -result $result {*}$args
}
testzipfswrite create-w test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile w -returnCodes error
testzipfswrite create-w+ test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile w+ -returnCodes error
testzipfswrite create-a test.zip "file \"$defMountPt/newfile\" not created: operation not supported" newfile a -returnCodes error
testzipfswrite create-a+ test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile a+ -returnCodes error
testzipfswrite store-w teststored.zip "xyz" abac-repeat.txt w
testzipfswrite deflate-w testdeflated2.zip "xyz" abac-repeat.txt w
testzipfswrite store-w+ teststored.zip "xyz" abac-repeat.txt w+
testzipfswrite deflate-w+ testdeflated2.zip "xyz" abac-repeat.txt w+
testzipfswrite stored-a teststored.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZxyz" abac-repeat.txt a
testzipfswrite deflate-a testdeflated2.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZxyz" abac-repeat.txt a
testzipfswrite store-a+ teststored.zip "xyzaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZ" abac-repeat.txt a+
testzipfswrite deflate-a+ testdeflated2.zip "xyzaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZ" abac-repeat.txt a+
testzipfswrite bug-23dd83ce7c-w empty.zip "xyz" empty.txt w
test zipfs-write-unreadable "Reads not allowed on file opened for write" -setup {
mount [zippath test.zip]
} -cleanup {
close $fd
cleanup
} -body {
set fd [open [file join $defMountPt test] w]
read $fd
} -result {channel "*" wasn't opened for reading} -match glob -returnCodes error
test zipfs-write-persist "Writes persist ONLY while mounted" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set path [file join $defMountPt test]
set fd [open $path w]
puts -nonewline $fd newtext
close $fd
set fd [open $path]
set result [list [read $fd]]
close $fd
zipfs unmount $defMountPt
mount [zippath test.zip]
set fd [open $path]
lappend result [read $fd]
close $fd
set result
} -result [list newtext test\n]
test zipfs-write-size-limit-0 "Writes more than size limit with flush" -setup {
set origlimit $::tcl::zipfs::wrmax
mount [zippath test.zip]
} -cleanup {
close $fd
set ::tcl::zipfs::wrmax $origlimit
cleanup
} -body {
set ::tcl::zipfs::wrmax 10
set fd [open [file join $defMountPt test] w]
puts $fd [string repeat x 11]
flush $fd
} -result {error flushing *: file too large} -match glob -returnCodes error
test zipfs-write-size-limit-1 "Writes size limit on close" -setup {
set origlimit $::tcl::zipfs::wrmax
mount [zippath test.zip]
} -cleanup {
set ::tcl::zipfs::wrmax $origlimit
cleanup
} -body {
set ::tcl::zipfs::wrmax 10
set fd [open [file join $defMountPt test] w]
puts $fd [string repeat x 11]
close $fd
} -result {file too large} -match glob -returnCodes error
test zipfs-write-size-limit-2 "Writes max size" -setup {
set origlimit $::tcl::zipfs::wrmax
set ::tcl::zipfs::wrmax 10000000
mount [zippath test.zip]
} -cleanup {
set ::tcl::zipfs::wrmax $origlimit
cleanup
} -body {
set fd [open [file join $defMountPt test] w]
puts -nonewline $fd [string repeat x $::tcl::zipfs::wrmax]
close $fd
file size [file join $defMountPt test]
} -result 10000000
test zipfs-write-size-limit-3 "Writes incrementally - buffer growth" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set fd [open [file join $defMountPt test] w]
fconfigure $fd -buffering none
for {set i 0} {$i < 100000} {incr i} {
puts -nonewline $fd 0123456789
}
close $fd
readbin [file join $defMountPt test]
} -result [string repeat 0123456789 100000]
test zipfs-write-size-limit-4 "Writes disallowed" -setup {
set origlimit $::tcl::zipfs::wrmax
mount [zippath test.zip]
} -cleanup {
set ::tcl::zipfs::wrmax $origlimit
cleanup
} -body {
set ::tcl::zipfs::wrmax -1
open [file join $defMountPt test] w
} -result {writes not permitted: permission denied} -returnCodes error
#
# read/seek/write
proc testzipfsrw {id zippath expected filename mode args} {
variable defMountPt
set zippath [zippath $zippath]
set path [file join $defMountPt $filename]
set body {
set result ""
set fd [open $path $mode]
fconfigure $fd -translation binary
append result [gets $fd],
set pos [tell $fd]
append result $pos,
puts -nonewline $fd "0123456789"
append result [gets $fd],
seek $fd $pos
append result [gets $fd],
seek $fd -6 end
append result [read $fd]|
close $fd
# Reopen after closing - bug [f91ee30d3]
set fd [open $path rb]
append result [read $fd]
}
test zipfs-rw-$id "zipfs read/seek/write $id" -setup {
unset -nocomplain fd
zipfs mount $zippath $defMountPt
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body $body -result $expected {*}$args
set data [readbin $zippath]
test zipfs-rw-memory-$id "zipfs read/seek/write in-memory $id" -setup {
unset -nocomplain fd
zipfs mountdata $data $defMountPt
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body $body -result $expected {*}$args
}
testzipfsrw store-r+ teststored.zip "aaaaaaaaaaaaaa,15,bbbb,0123456789bbbb,ccccc\n|aaaaaaaaaaaaaa\n0123456789bbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n" abac-repeat.txt r+
testzipfsrw store-w+ teststored.zip ",0,,0123456789,456789|0123456789" abac-repeat.txt w+
testzipfsrw store-a+ teststored.zip ",60,,0123456789,456789|aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n0123456789" abac-repeat.txt a+
testzipfsrw deflate-r+ testdeflated2.zip "aaaaaaaaaaaaaa,15,bbbb,0123456789bbbb,ccccc\n|aaaaaaaaaaaaaa\n0123456789bbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n" abac-repeat.txt r+
testzipfsrw deflate-w+ testdeflated2.zip ",0,,0123456789,456789|0123456789" abac-repeat.txt w+
testzipfsrw deflate-a+ testdeflated2.zip ",60,,0123456789,456789|aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n0123456789" abac-repeat.txt a+
test zipfs-rw-bug-f91ee30d33 "Bug f91ee30d33 - truncates at last read" -setup {
mount [zippath test.zip]
} -cleanup {
close $fd
cleanup
} -body {
set path [file join $defMountPt test]
set fd [open $path r+]
puts -nonewline $fd X
close $fd
set fd [open $path r]
read $fd
} -result "Xest\n"
#
# Password protected
proc testpasswordr {id zipfile filename password result args} {
variable defMountPt
set zippath [zippath $zipfile]
test zipfs-password-read-$id "zipfs password read $id" -setup {
unset -nocomplain fd
if {$password ne ""} {
zipfs mount $zippath $defMountPt $password
} else {
zipfs mount $zippath $defMountPt
}
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body {
set fd [open [file join $defMountPt $filename]]
gets $fd
} -result $result {*}$args -constraints bbe7c6ff9e
}
# The bug bbe7c6ff9e only manifests on macos
testConstraint bbe7c6ff9e [expr {$::tcl_platform(os) ne "Darwin"}]
# NOTE: test-password.zip is the DOS time based encryption header validity check (infozip style)
# test-password2.zip is the CRC based encryption header validity check (pkware style)
testpasswordr plain test-password.zip plain.txt password plaintext
testpasswordr plain-nopass test-password.zip plain.txt "" plaintext
testpasswordr plain-badpass test-password.zip plain.txt badpassword plaintext
testpasswordr cipher-1 test-password.zip cipher.bin password ciphertext
testpasswordr cipher-2 test-password2.zip cipher.bin password ciphertext
testpasswordr cipher-nopass-1 test-password.zip cipher.bin {} "decryption failed - no password provided" -returnCodes error
testpasswordr cipher-nopass-2 test-password2.zip cipher.bin {} "decryption failed - no password provided" -returnCodes error
testpasswordr cipher-badpass-1 test-password.zip cipher.bin badpassword "invalid password" -returnCodes error
testpasswordr cipher-badpass-2 test-password2.zip cipher.bin badpassword "invalid password" -returnCodes error
testpasswordr cipher-deflate test-password.zip cipher-deflate.bin password [lseq 100]
testpasswordr cipher-deflate-nopass test-password.zip cipher-deflate.bin {} "decryption failed - no password provided" -returnCodes error
testpasswordr cipher-deflate-badpass test-password.zip cipher-deflate.bin badpassword "invalid password" -returnCodes error
proc testpasswordw {id zippath filename password mode result args} {
variable defMountPt
set zippath [zippath $zippath]
set path [file join $defMountPt $filename]
set body {
set fd [open $path $mode]
fconfigure $fd -translation binary
puts -nonewline $fd "xyz"
close $fd
set fd [open $path]
fconfigure $fd -translation binary
read $fd
}
test zipfs-password-write-$id "zipfs write $id" -setup {
unset -nocomplain fd
if {$password ne ""} {
zipfs mount $zippath $defMountPt $password
} else {
zipfs mount $zippath $defMountPt
}
} -cleanup {
# In case open succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body $body -result $result {*}$args -constraints bbe7c6ff9e
}
# NOTE: test-password.zip is the DOS time based encryption header validity check (infozip style)
# test-password2.zip is the CRC based encryption header validity check (pkware style)
testpasswordw cipher-w-1 test-password.zip cipher.bin password w xyz
testpasswordw cipher-w-2 test-password2.zip cipher.bin password w xyz
testpasswordw cipher-deflate-w test-password2.zip cipher-deflate.bin password w xyz
testpasswordw cipher-badpass-w-1 test-password.zip cipher.bin badpass w {invalid password} -returnCodes error
|
| ︙ | ︙ | |||
1330 1331 1332 1333 1334 1335 1336 |
testpasswordw cipher-deflate-a+ test-password2.zip cipher-deflate.bin password a+ [lseq 100]xyz
testpasswordw cipher-badpass-a+ test-password.zip cipher.bin badpass a+ {invalid password} -returnCodes error
testpasswordw cipher-badpass-deflate-a+ test-password2.zip cipher-deflate.bin badpass a+ {invalid password} -returnCodes error
#
# CRC errors
proc testcrc {id zippath filename result args} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
testpasswordw cipher-deflate-a+ test-password2.zip cipher-deflate.bin password a+ [lseq 100]xyz
testpasswordw cipher-badpass-a+ test-password.zip cipher.bin badpass a+ {invalid password} -returnCodes error
testpasswordw cipher-badpass-deflate-a+ test-password2.zip cipher-deflate.bin badpass a+ {invalid password} -returnCodes error
#
# CRC errors
proc testcrc {id zippath filename result args} {
variable defMountPt
set zippath [zippath $zippath]
test zipfs-crc-$id "zipfs crc $id" -setup {
unset -nocomplain fd
zipfs mount $zippath $defMountPt
} -cleanup {
# In case mount succeeded when it should not
if {[info exists fd]} {
close $fd
}
cleanup
} -body {
set fd [open [file join $defMountPt $filename]]
} -result $result -returnCodes error {*}$args
# Mount memory buffer
test zipfs-crc-memory-$id "zipfs crc memory $id" -setup {
zipfs mountdata [readbin [zippath $zippath]] $defMountPt
} -cleanup {
cleanup
} -body {
set fd [open [file join $defMountPt $filename]]
} -result $result -returnCodes error {*}$args
}
testcrc local incons-local-crc.zip a "invalid CRC"
testcrc store-crc broken.zip storedcrcerror "invalid CRC"
testcrc deflate-crc broken.zip deflatecrcerror "invalid CRC"
test zipfs-crc-false-positives {
Verify no false positives in CRC checking
} -constraints zipfslib -body {
# Just loop ensuring no crc failures
foreach f [zipfs list] {
if {[file isfile $f]} {
close [open $f]
incr count
}
}
expr {$count > 0}
} -result 1
#
# file stat,lstat
proc fixuptime {t} {
# To compensate for the lack of timezone in zip, all dates
# expressed as strings and translated to local time
if {[regexp {^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d} $t]} {
return [clock scan $t -format "%Y-%m-%d %H:%M:%S"]
}
return $t
}
proc fixupstat {stat} {
foreach key {atime ctime mtime} {
# ZIP files have no TZ info so zipfs uses mktime which is localtime
dict set stat $key [fixuptime [dict get $stat $key]]
}
if {$::tcl_platform(platform) ne "windows"} {
dict set stat blksize 0
dict set stat blocks 0
}
return [lsort -stride 2 $stat]
}
# Wraps stat and lstat
proc testzipfsstat {id mountpoint target result args} {
test zipfs-file-stat-$id "file stat $id" -setup {
zipfs mount [zippath test.zip] $mountpoint
} -cleanup cleanup -body {
lsort -stride 2 [file stat [file join $mountpoint $target]]
} -result $result {*}$args
test zipfs-file-lstat-$id "file lstat $id" -setup {
mount [zippath test.zip]
} -cleanup cleanup -body {
lsort -stride 2 [file lstat [file join $mountpoint $target]]
} -result $result {*}$args
}
testzipfsstat enoent $defMountPt enoent "could not read \"[file join $defMountPt enoent]\": no such file or directory" -returnCodes error
testzipfsstat nosuchmount $defMountPt //zipfs:/notamount/test "could not read \"//zipfs:/notamount/test\": no such file or directory" -returnCodes error
testzipfsstat file $defMountPt test [fixupstat {atime {2003-10-06 15:46:42} ctime {2003-10-06 15:46:42} dev 0 gid 0 ino 0 mode 33133 mtime {2003-10-06 15:46:42} nlink 0 size 5 type file uid 0}]
testzipfsstat dir $defMountPt testdir [fixupstat {atime {2005-01-11 19:03:54} ctime {2005-01-11 19:03:54} dev 0 gid 0 ino 0 mode 16749 mtime {2005-01-11 19:03:54} nlink 0 size 0 type directory uid 0}]
testzipfsstat root-mount [zipfs root] [zipfs root] [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp
testzipfsstat root-subdir-mount $defMountPt [zipfs root] [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp
testzipfsstat mezzo [file join $defMountPt mt2] $defMountPt [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp
#
# glob of zipfs file
proc testzipfsglob {id mounts cmdopts result args} {
set setup {
foreach {zippath mountpoint} $mounts {
zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint]
}
}
if {[dict exists $args -setup]} {
append setup \n[dict get $args -setup]
dict unset args -setup
}
set cleanup cleanup
if {[dict exists $args -cleanup]} {
set cleanup "[dict get $args -cleanup]\n$cleanup"
dict unset args -cleanup
}
test zipfs-glob-$id "zipfs glob $id $cmdopts" -body {
lsort [glob {*}$cmdopts]
} -setup $setup -cleanup $cleanup -result $result {*}$args
}
set basicMounts [list test.zip $defMountPt]
testzipfsglob basic $basicMounts [list $defMountPt/*] [zipfspathsmt $defMountPt test testdir]
testzipfsglob basic-pat $basicMounts [list $defMountPt/t*d*] [zipfspathsmt $defMountPt testdir]
testzipfsglob basic-deep $basicMounts [list $defMountPt/tes*/*] [zipfspathsmt $defMountPt testdir/test2]
testzipfsglob basic-dir $basicMounts [list -directory $defMountPt *] [zipfspathsmt $defMountPt test testdir]
testzipfsglob basic-dir-tails $basicMounts [list -tails -dir $defMountPt *] [list test testdir]
testzipfsglob basic-type-d $basicMounts [list -type d $defMountPt/*] [zipfspathsmt $defMountPt testdir]
testzipfsglob basic-type-f $basicMounts [list -type f $defMountPt/*] [zipfspathsmt $defMountPt test]
testzipfsglob basic-type-d-f $basicMounts [list -type {d f} $defMountPt/*] [zipfspathsmt $defMountPt test testdir]
testzipfsglob basic-type-l $basicMounts [list -type l $defMountPt/*] {}
foreach type {b c l p s} {
testzipfsglob basic-type-1-$type $basicMounts [list -type $type $defMountPt/*] {}
testzipfsglob basic-type-f-$type $basicMounts [list -type [list f $type] $defMountPt/*] [zipfspathsmt $defMountPt test]
testzipfsglob basic-type-d-$type $basicMounts [list -type [list d $type] $defMountPt/*] [zipfspathsmt $defMountPt testdir]
}
testzipfsglob basic-path $basicMounts [list -path $defMountPt/t *d*] [zipfspathsmt $defMountPt testdir]
testzipfsglob basic-enoent $basicMounts [list $defMountPt/x*] {}
testzipfsglob basic-enoent-ok $basicMounts [list -nocomplain $defMountPt/x*] {}
# NOTE: test root mounts separately because some bugs only showed up on these
set rootMounts [list test.zip /]
|
| ︙ | ︙ | |||
1484 1485 1486 1487 1488 1489 1490 |
testzipfsglob mezzo-mountgrandparent $mezzoMounts [list $defMountPt/*] [list $defMountPt/a]
testzipfsglob mezzo-mountparent $mezzoMounts [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b c]
testzipfsglob mezzo-overlay [list test.zip $defMountPt/a/b test-overlay.zip $defMountPt/a] [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b test2 test3]
#
# file attributes
proc testzipfsfileattr [list id path result [list mountpoint $defMountPt] args] {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
testzipfsglob mezzo-mountgrandparent $mezzoMounts [list $defMountPt/*] [list $defMountPt/a]
testzipfsglob mezzo-mountparent $mezzoMounts [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b c]
testzipfsglob mezzo-overlay [list test.zip $defMountPt/a/b test-overlay.zip $defMountPt/a] [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b test2 test3]
#
# file attributes
proc testzipfsfileattr [list id path result [list mountpoint $defMountPt] args] {
test zipfs-file-attrs-$id "zipfs file attrs $id" -setup {
mount [zippath test.zip] $mountpoint
} -cleanup cleanup -body {
lsort -stride 2 [file attributes $path]
} -result $result {*}$args
}
testzipfsfileattr noent [file join $defMountPt nosuchfile] \
{file not found: no such file or directory} $defMountPt -returnCodes error
testzipfsfileattr file [file join $defMountPt test] \
[list -archive [zippath test.zip] -compsize 5 -crc [expr 0x3BB935C6] -mount $defMountPt -offset 55 -permissions 0o555 -uncompsize 5]
testzipfsfileattr dir [file join $defMountPt testdir] \
[list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defMountPt -offset 119 -permissions 0o555 -uncompsize 0]
testzipfsfileattr root [zipfs root] {-archive {} -compsize 0 -crc 0 -mount {} -offset 0 -permissions 0o555 -uncompsize 0}
testzipfsfileattr mountpoint $defMountPt \
[list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defMountPt -offset 0 -permissions 0o555 -uncompsize 0]
testzipfsfileattr mezzo [file join $defMountPt a b] {-archive {} -compsize 0 -crc 0 -mount {} -offset 0 -permissions 0o555 -uncompsize 0} [file join $defMountPt a b c]
foreach attr {-uncompsize -compsize -offset -mount -archive -permissions -crc} {
test zipfs-file-attrs-set$attr "Set zipfs file attribute $attr" -setup {
mount [zippath test.zip]
} -cleanup cleanup \
-body "file attributes [file join $defMountPt test] $attr {}" \
-result "unsupported operation" -returnCodes error
}
#
# file normalize
proc testzipfsnormalize {id path result {dir {}}} {
if {$dir eq ""} {
test zipfs-file-normalize-$id "zipfs file normalize $id" -body {
file normalize $path
} -result $result
} else {
test zipfs-file-normalize-$id "zipfs file normalize $id" -setup {
set cwd [pwd]
mount [zippath test.zip] [zipfs root]
cd $dir
} -cleanup {
cd $cwd
cleanup
} -body {
file normalize $path
} -result $result
}
}
# The parsing requires all these cases for various code paths
# in particular, root, one below root and more than one below root
testzipfsnormalize dot-1 [zipfs root] [zipfs root]
testzipfsnormalize dot-2 [file join [zipfs root] .] [zipfs root]
testzipfsnormalize dot-3 [file join [zipfs root] . .] [zipfs root]
testzipfsnormalize dot-4 [file join [zipfs root] a .] [file join [zipfs root] a]
|
| ︙ | ︙ | |||
1566 1567 1568 1569 1570 1571 1572 |
testzipfsnormalize relative-12 dir/../a/ [file join [zipfs root] a] [zipfs root]
testzipfsnormalize relative-13 dir/../../../a [file join [zipfs root] a] [zipfs root]
testzipfsnormalize relative-14 a [file join [zipfs root] testdir a] [file join [zipfs root] testdir]
#
# file copy
test zipfs-file-copy-tozip-new {Copy native file to archive} -setup {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
testzipfsnormalize relative-12 dir/../a/ [file join [zipfs root] a] [zipfs root]
testzipfsnormalize relative-13 dir/../../../a [file join [zipfs root] a] [zipfs root]
testzipfsnormalize relative-14 a [file join [zipfs root] testdir a] [file join [zipfs root] testdir]
#
# file copy
test zipfs-file-copy-tozip-new {Copy native file to archive} -setup {
mount [zippath test.zip]
} -cleanup {
removeFile $_
cleanup
} -body {
file copy [set _ [makeFile "" source.tmp]] [file join $defMountPt X]
} -result "error copying \"*source.tmp\" to \"[file join $defMountPt X]\": operation not supported" \
-match glob -returnCodes error
test zipfs-file-copy-tozip-existing {Copy native file to archive} -setup {
mount [zippath test.zip]
} -cleanup {
removeFile $_
cleanup
} -body {
file copy [set _ [makeFile "newtext" source.tmp]] [file join $defMountPt test]
} -result "error copying *: file exists" -match glob -returnCodes error
test zipfs-file-copy-tozip-existing-force {Copy native file to archive} -setup {
mount [zippath test.zip]
} -cleanup {
removeFile $_
cleanup
} -body {
set to [file join $defMountPt test]
file copy -force [set _ [makeFile "newtext" source.tmp]] $to
readbin $to
} -result "newtext\n"
test zipfs-file-copy-tozipdir {Copy native file to archive directory} -setup {
mount [zippath test.zip]
} -cleanup {
removeFile $_
cleanup
} -body {
file copy [set _ [makeFile "" source.tmp]] [file join $defMountPt testdir]
} -result "error copying \"*source.tmp\" to \"[file join $defMountPt testdir]/source.tmp\": operation not supported" \
-match glob -returnCodes error
test zipfs-file-copydir-tozipdir {Copy native dir to archive directory} -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
file copy [temporaryDirectory] [file join $defMountPt testdir]
} -result "can't create directory *: operation not supported" \
-match glob -returnCodes error
test zipfs-file-copy-fromzip-new {Copy archive file to native} -setup {
mount [zippath test.zip]
set dst [file join [temporaryDirectory] dst.tmp]
file delete $dst
} -cleanup {
file delete $dst
cleanup
} -body {
file copy [file join $defMountPt test] $dst
readbin $dst
} -result "test\n"
test zipfs-file-copydir-fromzip-1 {Copy archive dir to native} -setup {
mount [zippath test.zip]
set dst [file join [temporaryDirectory] dstdir.tmp]
file delete -force $dst
} -cleanup {
file delete -force $dst
cleanup
} -body {
file copy [file join $defMountPt testdir] $dst
zipfs find $dst
} -result [file join [temporaryDirectory] dstdir.tmp test2]
test zipfs-file-copymount-fromzip-new {Copy archive mount to native} -setup {
mount [zippath test.zip]
set dst [file join [temporaryDirectory] dstdir2.tmp]
file delete -force $dst
} -cleanup {
file delete -force $dst
cleanup
} -body {
file copy $defMountPt $dst
list [file isfile [file join $dst test]] \
[file isdirectory [file join $dst testdir]] \
[file isfile [file join $dst testdir test2]]
} -result {1 1 1}
#
# file delete
test zipfs-file-delete "Delete file in zip archive" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set file [file join $defMountPt test]
list \
[file exists $file] \
[catch {file delete $file} msg] \
$msg \
[file exists $file]
} -result [list 1 1 {error deleting "//zipfs:/testmount/test": operation not supported} 1]
test zipfs-file-delete-enoent "Delete nonexisting path in zip archive" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set file [file join $defMountPt enoent]
list \
[file exists $file] \
[catch {file delete $file} msg] \
$msg \
[file exists $file]
} -result [list 0 0 {} 0]
test zipfs-file-delete-dir "Delete dir in zip archive" -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set dir [file join $defMountPt testdir]
list \
[file isdirectory $dir] \
[catch {file delete -force $dir} msg] \
$msg \
[file isdirectory $dir]
} -result [list 1 1 {error deleting unknown file: operation not supported} 1]
#
# file join
test zipfs-file-join-1 "Ensure file join recognizes zipfs path as absolute" -body {
file join /abc [zipfs root]a/b/c
} -result [zipfs root]a/b/c
#
# file mkdir
test zipfs-file-mkdir {Make a directory in zip archive} -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
file mkdir [file join $defMountPt newdir]
} -result "can't create directory \"[file join $defMountPt newdir]\": operation not supported" -returnCodes error
test zipfs-file-mkdir-existing {Make a an existing directory in zip archive} -setup {
mount [zippath test.zip]
} -cleanup {
cleanup
} -body {
set dir [file join $defMountPt testdir]
file mkdir $dir
file isdirectory $dir
} -result 1
# Standard paths for file command tests. Because code paths are different,
# we need tests for...
set targetMountParent $defMountPt; # Parent of mount directory
set targetMount [file join $targetMountParent mt] ; # Mount directory
set targetFile [file join $targetMount test]; # Normal file
set targetDir [file join $targetMount testdir]; # Directory
set targetEnoent [file join $targetMount enoent]; # Non-existing path
proc testzipfsfile {id cmdargs result args} {
variable targetMount
test zipfs-file-$id "file $id on zipfs" -setup {
zipfs mount [zippath test.zip] $targetMount
} -cleanup cleanup -body {
file {*}$cmdargs
} -result $result {*}$args
}
proc testzipfsenotsup {id cmdargs args} {
testzipfsfile $id $cmdargs "*: operation not supported" -match glob -returnCodes error
}
#
# file atime
testzipfsfile atime-get-file [list atime $targetFile] [fixuptime {2003-10-06 15:46:42}]
testzipfsfile atime-get-dir [list atime $targetDir] [fixuptime {2005-01-11 19:03:54}]
testzipfsfile atime-get-mount [list atime $targetMount] {\d+} -match regexp
testzipfsfile atime-get-mezzo [list atime $targetMountParent] {\d+} -match regexp
testzipfsfile atime-get-root [list atime [zipfs root]] {\d+} -match regexp
testzipfsfile atime-get-enoent [list atime $targetEnoent] \
"could not read \"$targetEnoent\": no such file or directory" -returnCodes error
set t [clock seconds]
testzipfsenotsup atime-set-file [list atime $targetFile $t]
testzipfsenotsup atime-set-dir [list atime $targetDir $t]
testzipfsenotsup atime-set-mount [list atime $targetMount $t]
testzipfsenotsup atime-set-mezzo [list atime $targetMountParent $t]
testzipfsenotsup atime-set-root [list atime [zipfs root] $t]
testzipfsfile atime-set-enoent [list atime $targetEnoent $t] \
"could not read \"$targetEnoent\": no such file or directory" -returnCodes error
#
# file dirname
testzipfsfile dirname-file [list dirname $targetFile] $targetMount
testzipfsfile dirname-dir [list dirname $targetDir] $targetMount
testzipfsfile dirname-mount [list dirname $targetMount] $targetMountParent
testzipfsfile dirname-mezzo [list dirname $targetMountParent] [zipfs root]
|
| ︙ | ︙ | |||
1811 1812 1813 1814 1815 1816 1817 |
testzipfsfile mtime-get-file [list mtime $targetFile] [fixuptime {2003-10-06 15:46:42}]
testzipfsfile mtime-get-dir [list mtime $targetDir] [fixuptime {2005-01-11 19:03:54}]
testzipfsfile mtime-get-mount [list mtime $targetMount] {\d+} -match regexp
testzipfsfile mtime-get-mezzo [list mtime $targetMountParent] {\d+} -match regexp
testzipfsfile mtime-get-root [list mtime [zipfs root]] {\d+} -match regexp
testzipfsfile mtime-set-enoent [list mtime $targetEnoent $t] \
| | | | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 |
testzipfsfile mtime-get-file [list mtime $targetFile] [fixuptime {2003-10-06 15:46:42}]
testzipfsfile mtime-get-dir [list mtime $targetDir] [fixuptime {2005-01-11 19:03:54}]
testzipfsfile mtime-get-mount [list mtime $targetMount] {\d+} -match regexp
testzipfsfile mtime-get-mezzo [list mtime $targetMountParent] {\d+} -match regexp
testzipfsfile mtime-get-root [list mtime [zipfs root]] {\d+} -match regexp
testzipfsfile mtime-set-enoent [list mtime $targetEnoent $t] \
"could not read \"$targetEnoent\": no such file or directory" -returnCodes error
set t [clock seconds]
testzipfsenotsup mtime-set-file [list mtime $targetFile $t]
testzipfsenotsup mtime-set-dir [list mtime $targetDir $t]
testzipfsenotsup mtime-set-mount [list mtime $targetMount $t]
testzipfsenotsup mtime-set-mezzo [list mtime $targetMountParent $t]
testzipfsenotsup mtime-set-root [list mtime [zipfs root] $t]
testzipfsfile mtime-set-enoent-1 [list mtime $targetEnoent $t] \
"could not read \"$targetEnoent\": no such file or directory" -returnCodes error
#
# file owned
testzipfsfile owned-file [list owned $targetFile] 1
testzipfsfile owned-dir [list owned $targetDir] 1
testzipfsfile owned-mount [list owned $targetMount] 1
testzipfsfile owned-mezzo [list owned $targetMountParent] 1
|
| ︙ | ︙ | |||
1856 1857 1858 1859 1860 1861 1862 |
# file size
testzipfsfile size-file [list size $targetFile] 5
testzipfsfile size-dir [list size $targetDir] 0
testzipfsfile size-mount [list size $targetMount] 0
testzipfsfile size-mezzo [list size $targetMountParent] 0
testzipfsfile size-root [list size [zipfs root]] 0
testzipfsfile size-enoent [list size $targetEnoent] \
| | | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 |
# file size
testzipfsfile size-file [list size $targetFile] 5
testzipfsfile size-dir [list size $targetDir] 0
testzipfsfile size-mount [list size $targetMount] 0
testzipfsfile size-mezzo [list size $targetMountParent] 0
testzipfsfile size-root [list size [zipfs root]] 0
testzipfsfile size-enoent [list size $targetEnoent] \
"could not read \"$targetEnoent\": no such file or directory" -returnCodes error
#
# file split
testzipfsfile split-file [list split $targetFile] [list [zipfs root] testmount mt test]
testzipfsfile split-root [list split [zipfs root]] [list [zipfs root]]
testzipfsfile split-enoent [list split $targetEnoent] [list [zipfs root] testmount mt enoent]
|
| ︙ | ︙ | |||
1899 1900 1901 1902 1903 1904 1905 |
testnumargs "zipfs mkzip" "outfile indir" "?strip? ?password?"
testnumargs "zipfs lmkzip" "outfile inlist" "?password?"
#
# Bug regressions
test bug-6ed3447a7e "Crash opening file in streamed archive" -setup {
| | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > | 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 |
testnumargs "zipfs mkzip" "outfile indir" "?strip? ?password?"
testnumargs "zipfs lmkzip" "outfile inlist" "?password?"
#
# Bug regressions
test bug-6ed3447a7e "Crash opening file in streamed archive" -setup {
mount [zippath streamed.zip]
} -cleanup {
cleanup
} -body {
set fd [open [file join $defMountPt -]]
list [catch {read $fd} message] [close $fd] $message
close $fd
} -result {file size error (may be zip64)} -returnCodes error
test bug-8259d74a64 "Crash exiting with open files" -setup {
set path [zippath test.zip]
set script "zipfs mount $path /\n"
append script {open [zipfs root]test} \n
append script "exit\n"
} -body {
set fd [open |[info nameofexecutable] r+]
puts $fd $script
flush $fd
read $fd
close $fd
} -result ""
# Following will only show a leak with valgrind
test bug-9525f4c8bc "Memory leak with long mount paths" -body {
set mt //zipfs:[string repeat /x 240]
zipfs mount [zippath test.zip] $mt
zipfs unmount $mt
} -result ""
test bug-33b2486199 "zipfs unmounted on thread exit" -constraints {
thread
} -body {
set before [lsort [zipfs mount]]
thread::release [thread::create]
after 100; # Needed to allow the spawned thread to exit to trigger bug
string equal $before [lsort [zipfs mount]]
} -result 1
test bug-7d5f1c1308 "zipfs error on dotfiles" -setup {
set basename bug-7d5f1c1308
set mt //zipfs:/$basename-mt
set zipfile $basename.zip
set dir [makeDirectory $basename]
close [open [file join $dir .ext] w]
} -cleanup {
zipfs unmount $mt
file delete $zipfile
removeDirectory $basename
} -body {
zipfs mkzip $zipfile $dir [file dirname $dir]
zipfs mount $zipfile $mt
lsort [zipfs list $mt/*]
} -result {//zipfs:/bug-7d5f1c1308-mt/bug-7d5f1c1308 //zipfs:/bug-7d5f1c1308-mt/bug-7d5f1c1308/.ext}
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/zlib.test.
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
gets $f
} -cleanup {
close $f
removeFile $file
} -result ok
test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
| | | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
gets $f
} -cleanup {
close $f
removeFile $file
} -result ok
test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
fconfigure $c -translation binary -buffering none -blocking 0
puts -nonewline $c [zlib gzip [string repeat a 81920]]
close $c
}}} 0]
set port [lindex [fconfigure $srv -sockname] 2]
set file [makeFile {} test.gz]
set fout [open $file wb]
} -body {
set sin [socket localhost $port]
try {
|
| ︙ | ︙ | |||
316 317 318 319 320 321 322 |
fconfigure $outSide -blocking 1 -translation binary -buffering none
fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
chan close $outSide
set compressed [read $inSide]
catch {zlib decompress $compressed} err opt
| | < | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
fconfigure $outSide -blocking 1 -translation binary -buffering none
fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
chan close $outSide
set compressed [read $inSide]
catch {zlib decompress $compressed} err opt
list [string length [zlib decompress [zlib compress $spdyHeaders]]] \
$err [dict get $opt -errorcode] [zlib adler32 $spdyDict]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
} -result {358 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010}
test zlib-8.9 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream decompress]
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 1 -translation binary -buffering none
fconfigure $inSide -blocking 1 -translation binary
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
set file [makeFile {} test.gz]
} -constraints zlib -body {
set f [open $file wb]
fconfigure $f -buffering none
zlib push gzip $f
puts -nonewline $f $largeData
close $f
| | | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
set file [makeFile {} test.gz]
} -constraints zlib -body {
set f [open $file wb]
fconfigure $f -buffering none
zlib push gzip $f
puts -nonewline $f $largeData
close $f
expr {[file size $file]<57648}
} -cleanup {
removeFile $file
} -result 1
test zlib-8.17 {Bug dd260aaf: fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push inflate $inSide
zlib push deflate $outSide
list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary]
} -cleanup {
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 |
list copied $total size [file size $file]
} -cleanup {
removeFile $file
removeFile $sfile
} -result {copied 81920 size 81920}
test zlib-9.2 "socket fcopy with push" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
| | | | | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
list copied $total size [file size $file]
} -cleanup {
removeFile $file
removeFile $sfile
} -result {copied 81920 size 81920}
test zlib-9.2 "socket fcopy with push" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
puts -nonewline $c [zlib gzip [string repeat a 81920]]
close $c
set ::total -1
}}} 0]
set file [makeFile {} test.gz]
} -body {
lassign [chan configure $srv -sockname] addr name port
set sin [socket $addr $port]
chan configure $sin -translation binary
zlib push gunzip $sin
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
list read $total size [file size $file]
} -cleanup {
close $srv
removeFile $file
} -result {read 81920 size 81920}
test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
| | | | | | | | | | | | | | | | | | | | | | 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 |
list read $total size [file size $file]
} -cleanup {
close $srv
removeFile $file
} -result {read 81920 size 81920}
test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
#puts "connection from $a:$p on $c"
chan configure $c -translation binary -buffering none -blocking 0
puts -nonewline $c [string repeat a 81920]
close $c
}}} 0]
set file [makeFile {} test.gz]
} -body {
lassign [chan configure $srv -sockname] addr name port
#puts "listening for connections on $addr $port"
set sin [socket localhost $port]
chan configure $sin -translation binary
update
set fout [open $file wb]
after 1000 {set ::total timeout}
fcopy $sin $fout -command {apply {{c {e {}}} {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
close $srv
removeFile $file
} -returnCodes {ok error} -result {read 81920 size 81920}
test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
puts -nonewline $c [zlib gzip [string repeat a 81920]]
close $c
}}} 0]
set file [makeFile {} test.gz]
} -body {
lassign [chan configure $srv -sockname] addr name port
set sin [socket $addr $port]
chan configure $sin -translation binary
zlib push gunzip $sin
update
set fout [open $file wb]
after 1000 {set ::total timeout}
fcopy $sin $fout -command {apply {{c {e {}}} {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
close $srv
removeFile $file
} -result {read 81920 size 81920}
test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
puts -nonewline $c [zlib gzip [string repeat a 81920]]
close $c
}}} 0]
proc zlib95copy {i o t c {e {}}} {
incr t $c
if {$e ne {}} {
set ::total [list error $e]
} elseif {[eof $i]} {
set ::total [list eof $t]
} else {
fcopy $i $o -size 8192 -command [list zlib95copy $i $o $t]
}
}
set file [makeFile {} test.gz]
} -body {
lassign [chan configure $srv -sockname] addr name port
set sin [socket $addr $port]
chan configure $sin -translation binary
zlib push gunzip $sin
|
| ︙ | ︙ | |||
648 649 650 651 652 653 654 |
} -cleanup {
close $srv
rename zlib95copy {}
removeFile $file
} -result {{eof 81920} size 81920}
test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} -cleanup {
close $srv
rename zlib95copy {}
removeFile $file
} -result {{eof 81920} size 81920}
test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
zlib push gzip $c
puts -nonewline $c [string repeat hello 100]
close $c
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
chan configure $s -translation binary
zlib push gunzip $s
chan event $s readable [list apply {{s} {
set d [read $s]
if {[eof $s]} {
chan event $s readable {}
set ::total [list eof [string length $d]]
}
}} $s]
vwait ::total
after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
close $srv
unset -nocomplain total
} -result {eof 500}
test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
zlib push compress $c
puts -nonewline $c [string repeat hello 100]
close $c
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
chan configure $s -translation binary
zlib push decompress $s
chan event $s readable [list apply {{s} {
set d [read $s]
if {[eof $s]} {
chan event $s readable {}
set ::total [list eof [string length $d]]
}
}} $s]
vwait ::total
after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
close $srv
unset -nocomplain total
} -result {eof 500}
test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup {
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
zlib push deflate $c
puts -nonewline $c [string repeat hello 100]
close $c
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
chan configure $s -translation binary
zlib push inflate $s
chan event $s readable [list apply {{s} {
set d [read $s]
if {[eof $s]} {
chan event $s readable {}
set ::total [list eof [string length $d]]
}
}} $s]
vwait ::total
after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
unset -nocomplain total
close $srv
} -result {eof 500}
test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
proc bgerror {s} {set ::total [list error $s]}
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
zlib push gzip $c
puts -nonewline $c [string repeat hello 100]
close $c
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
try {
chan configure $s -translation binary
zlib push inflate $s
chan event $s readable [list apply {{s} {
set d [read $s]
if {[eof $s]} {
chan event $s readable {}
set ::total [list eof [string length $d]]
}
}} $s]
vwait ::total
} finally {
after cancel {set ::total timeout}
close $s
}
set ::total
} -cleanup {
unset -nocomplain total
close $srv
rename bgerror {}
} -result {error {invalid block type}}
test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
proc bgerror {s} {set ::total [list error $s]}
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
zlib push compress $c
puts -nonewline $c [string repeat hello 100]
close $c
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
try {
chan configure $s -translation binary
zlib push inflate $s
chan event $s readable [list apply {{s} {
set d [read $s]
if {[eof $s]} {
chan event $s readable {}
set ::total [list eof [string length $d]]
}
}} $s]
vwait ::total
} finally {
after cancel {set ::total timeout}
close $s
}
set ::total
} -cleanup {
unset -nocomplain total
close $srv
rename bgerror {}
} -result {error {invalid stored block lengths}}
test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
proc bgerror {s} {set ::total [list error $s]}
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary -buffering none -blocking 0
zlib push deflate $c
puts -nonewline $c [string repeat hello 100]
close $c
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
try {
chan configure $s -translation binary
zlib push gunzip $s
chan event $s readable [list apply {{s} {
set d [read $s]
if {[eof $s]} {
chan event $s readable {}
set ::total [list eof [string length $d]]
}
}} $s]
vwait ::total
} finally {
after cancel {set ::total timeout}
close $s
}
set ::total
} -cleanup {
unset -nocomplain total
close $srv
rename bgerror {}
} -result {error {incorrect header check}}
test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
zlib
} -setup {
proc bgerror {s} {set ::total [list error $s]}
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary
zlib push inflate $c
chan event $c readable [list apply {{c} {
set d [read $c]
if {[eof $c]} {
chan event $c readable {}
close $c
set ::total [list eof [string length $d]]
}
}} $c]
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
chan configure $s -translation binary -buffering none -blocking 0
zlib push gzip $s
chan event $s xyzzy [list apply {{s} {
if {[gets $s line] < 0} {
chan close $s
}
}} $s]
after idle [list apply {{s} {
puts $s test
chan close $s
after 100 {set ::total done}
}} $s]
vwait ::total
after cancel {set ::total timeout}
after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
rename bgerror {}
} -returnCodes error \
-result {bad event name "xyzzy": must be readable or writable}
test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
zlib
} -setup {
proc bgerror {s} {set ::total [list error $s]}
proc zlibRead {c} {
set d [read $c]
if {[eof $c]} {
chan event $c readable {}
close $c
set ::total [list eof [string length $d]]
}
}
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary
zlib push inflate $c
chan event $c readable [list zlibRead $c]
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
chan configure $s -translation binary -buffering none -blocking 0
zlib push gzip $s
chan event $s readable [list zlibRead $s]
after idle [list apply {{s} {
puts $s test
chan close $s
after 100 {set ::total done}
}} $s]
vwait ::total
after cancel {set ::total timeout}
after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
rename bgerror {}
rename zlibRead {}
} -result {error {invalid block type}}
test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
zlib
} -setup {
proc bgerror {s} {set ::total [list error $s]}
proc zlibRead {c} {
if {[gets $c line] < 0} {
close $c
set ::total [list error -1]
} elseif {[eof $c]} {
chan event $c readable {}
close $c
set ::total [list eof 0]
}
}
set srv [socket -myaddr localhost -server {apply {{c a p} {
chan configure $c -translation binary
zlib push inflate $c
chan event $c readable [list zlibRead $c]
}}} 0]
} -body {
lassign [chan configure $srv -sockname] addr name port
after 1000 {set ::total timeout}
set s [socket $addr $port]
chan configure $s -translation binary -buffering none -blocking 0
zlib push gzip $s
chan event $s readable [list zlibRead $s]
after idle [list apply {{s} {
puts $s test
chan close $s
after 100 {set ::total done}
}} $s]
vwait ::total
after cancel {set ::total timeout}
after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 |
} -result {458752 458752}
if {$zlibbinf ne ""} {
removeFile $zlibbinf
}
unset zlibbinf
rename _zlibbinf {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
} -result {458752 458752}
if {$zlibbinf ne ""} {
removeFile $zlibbinf
}
unset zlibbinf
rename _zlibbinf {}
test zlib-14.1 {Bug 9ee9f4d7be: compression header added to source channel} -setup {
set data hello
set src [file tempfile]
puts -nonewline $src $data
flush $src
chan configure $src -translation binary
set dst [file tempfile]
chan configure $dst -translation binary
set result {}
} -constraints knownBug -body {
for {set i 0} {$i < 3} {incr i} {
# Determine size of src channel
seek $src 0 end
set size [chan tell $src]
seek $src 0 start
# Determine size of content in src channel
set data [read $src]
set size2 [string length $data]
seek $src 0 start
# Copy src over to dst, keep dst empty
zlib push deflate $src -level 6
chan truncate $dst 0
chan copy $src $dst
set size3 [chan tell $dst]
chan pop $src
# Show sizes
lappend result $size $size2 ->$size3
}
return $result
} -cleanup {
chan close $src
chan close $dst
} -result {5 5 ->5 5 5 ->5 5 5 ->5}
test zlib-15.1 {Bug cfdf80a2efc6 - negative checksums} -setup {
set compressor [zlib stream gzip -header {comment "A zlib demo"}]
$compressor put abcd
$compressor finalize
} -body {
$compressor checksum
} -cleanup {
$compressor close
} -result 3984772369
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tools/encoding/txt2enc.c.
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
fputs(" -s\tsymbol+ascii encoding\n", stderr);
fputs(" -m\tdon't implicitly include 007F\n", stderr);
return 1;
}
fp = fopen(argv[argc - 1], "r");
if (fp == NULL) {
| | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
fputs(" -s\tsymbol+ascii encoding\n", stderr);
fputs(" -m\tdon't implicitly include 007F\n", stderr);
return 1;
}
fp = fopen(argv[argc - 1], "r");
if (fp == NULL) {
perror(argv[argc - 1]);
return 1;
}
for (i = 0; i < 256; i++) {
toUnicode[i] = NULL;
}
maxEnc = 0;
width = 0;
multiByte = 0;
while (fgets(buf, sizeof(buf), fp) != NULL) {
str = buf;
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 |
putchar('\n');
}
}
}
}
for (hi = 0; hi < 256; hi++) {
| | | | | | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
putchar('\n');
}
}
}
}
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
free(toUnicode[hi]);
toUnicode[hi] = NULL;
}
}
return 0;
}
|
Changes to tools/genStubs.tcl.
| ︙ | ︙ | |||
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 ""} {
| > > > > > > > > > > > > > > > | 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 |
append text [addPlatformGuard $plat $temp]
set emit 1
}
## aqua ##
set temp {}
set plat aqua
if {!$slot(unix) && !$slot(macosx)} {
if {[string range $skipString 1 2] ne "/*"} {
# genStubs.tcl previously had a bug here causing it to
# erroneously generate both a unix entry and an aqua
# entry for a given stubs table slot. To preserve
# backwards compatibility, generate a dummy stubs entry
# before every aqua entry (note that this breaks the
# correspondence between emitted entry number and
# actual position of the entry in the stubs table, e.g.
# TkIntStubs entry 113 for aqua is in fact at position
# 114 in the table, entry 114 at position 116 etc).
eval {append temp} $skipString
set temp "# if TCL_MAJOR_VERSION < 9\n[string range $temp 0 end-1] /*\
Dummy entry for stubs table backwards\
compatibility */\n# endif /* TCL_MAJOR_VERSION < 9 */\n"
}
if {$slot($plat)} {
append temp [$slotProc $name $stubs($name,$plat,$i) $i]
} elseif {$onAll} {
eval {append temp} $skipString
}
}
if {$temp ne ""} {
|
| ︙ | ︙ |
Changes to tools/index.tcl.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Global variables used by these scripts: # # state - state variable that controls action of text proc. # # topics - array indexed by (package,section,topic) with value | | | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Global variables used by these scripts: # # state - state variable that controls action of text proc. # # topics - array indexed by (package,section,topic) with value # of topic ID. # # keywords - array indexed by keyword string with value of topic ID. # # curID - current topic ID, starts at 0 and is incremented for # each new topic file. # # curPkg - current package name (e.g. Tcl). # # curSect - current section title (e.g. "Tcl Built-In Commands"). # # getPackages -- |
| ︙ | ︙ |
Changes to tools/installVfs.tcl.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 |
if {![info exists result]} {
set result {}
}
set queue [list $prefix $filepath]
while {[llength $queue]} {
set queue [lassign $queue qprefix qpath]
foreach ftail [glob -directory $qpath -nocomplain -tails *] {
| | | | | | | | | | | | | | 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 |
if {![info exists result]} {
set result {}
}
set queue [list $prefix $filepath]
while {[llength $queue]} {
set queue [lassign $queue qprefix qpath]
foreach ftail [glob -directory $qpath -nocomplain -tails *] {
set f [file join $qpath $ftail]
if {[file isdirectory $f]} {
if {$ftail eq "CVS"} continue
lappend queue [file join $qprefix $ftail] $f
} elseif {[file isfile $f]} {
if {$ftail eq "pkgIndex.tcl"} continue
if {$ftail eq "manifest.txt"} {
lappend result $f [file join $qprefix pkgIndex.tcl]
} else {
lappend result $f [file join $qprefix $ftail]
}
}
}
}
}
if {[llength $argv]<4} {
error "Usage: [file tail [info script]] IMG_OUTPUT IMG_INPUT PREFIX FILE_SYSTEM ?PREFIX FILE_SYSTEM?..."
}
|
| ︙ | ︙ |
Changes to tools/makeHeader.tcl.
| ︙ | ︙ | |||
104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
#
# updateTemplateFile --
# Rewrites a template file with the lines of the given script.
#
proc updateTemplateFile {headerFile scriptLines} {
set f [open $headerFile "r+"]
try {
set content [split [chan read -nonewline $f] "\n"]
updateTemplate content [stripSurround $scriptLines]
chan seek $f 0
chan puts $f [join $content \n]
chan truncate $f
} trap BAD msg {
# Add the filename to the message
| > | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
#
# updateTemplateFile --
# Rewrites a template file with the lines of the given script.
#
proc updateTemplateFile {headerFile scriptLines} {
set f [open $headerFile "r+"]
try {
chan configure $f -translation {auto lf}
set content [split [chan read -nonewline $f] "\n"]
updateTemplate content [stripSurround $scriptLines]
chan seek $f 0
chan puts $f [join $content \n]
chan truncate $f
} trap BAD msg {
# Add the filename to the message
|
| ︙ | ︙ |
Changes to tools/makeTestCases.tcl.
1 2 3 4 5 6 | # TODO - When integrating this with the Core, path names will need to be # swizzled here. package require msgcat set d [file dirname [file dirname [info script]]] puts "getting transition data from [file join $d library tzdata America Detroit]" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# TODO - When integrating this with the Core, path names will need to be
# swizzled here.
package require msgcat
set d [file dirname [file dirname [info script]]]
puts "getting transition data from [file join $d library tzdata America Detroit]"
source -encoding utf-8 [file join $d library/tzdata/America/Detroit]
namespace eval ::tcl::clock {
::msgcat::mcmset en_US_roman {
LOCALE_ERAS {
{-62164627200 {} 0}
{-59008867200 c 100}
{-55853107200 cc 200}
|
| ︙ | ︙ | |||
211 212 213 214 215 216 217 |
proc testcases2 { f2 } {
listYears startOfYear
# Define the roman numerals
set roman {
| | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
proc testcases2 { f2 } {
listYears startOfYear
# Define the roman numerals
set roman {
? i ii iii iv v vi vii viii ix
x xi xii xiii xiv xv xvi xvii xviii xix
xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
l li lii liii liv lv lvi lvii lviii lix
lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix
xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
c
}
set romanc {
? c cc ccc cd d dc dcc dccc cm
m mc mcc mccc mcd md mdc mdcc mdccc mcm
mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm
mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm
}
# Names of the months
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
set longdays {Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday}
set shortdays {Sun Mon Tue Wed Thu Fri Sat Sun}
puts $f2 "test clock-3.[incr case] {ISO week-based calendar [format %04d-W%02d-%d $G $V $u]} {"
puts $f2 " clock format $secs -format {%a %A %g %G %u %U %V %w %W} -gmt true; \# $G-W[format %02d $V]-$u"
puts $f2 "} {[lindex $shortdays $u] [lindex $longdays $u]\
| | | | | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 |
set longdays {Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday}
set shortdays {Sun Mon Tue Wed Thu Fri Sat Sun}
puts $f2 "test clock-3.[incr case] {ISO week-based calendar [format %04d-W%02d-%d $G $V $u]} {"
puts $f2 " clock format $secs -format {%a %A %g %G %u %U %V %w %W} -gmt true; \# $G-W[format %02d $V]-$u"
puts $f2 "} {[lindex $shortdays $u] [lindex $longdays $u]\
[format %02d [expr { $G % 100 }]] $G\
$u\
[clock format $secs -format %U -gmt true]\
[format %02d $V] [expr { $u % 7 }]\
[clock format $secs -format %W -gmt true]}"
}
#----------------------------------------------------------------------
#
# testcases4 --
#
|
| ︙ | ︙ |
Changes to tools/mkVfs.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
proc cat fname {
set fname [open $fname r]
set data [read $fname]
close $fname
return $data
}
proc pkgIndexDir {root fout d1} {
puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \
[file tail $d1]]
set idx [string length $root]
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
proc cat fname {
set fname [open $fname r]
set data [read $fname]
close $fname
return $data
}
proc pkgIndexDir {root fout d1} {
puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \
[file tail $d1]]
set idx [string length $root]
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
pkgIndexDir $root $fout $f
} elseif {[file tail $f] eq "pkgIndex.tcl"} {
puts $fout "set dir \${VFSROOT}[string range $d1 $idx end]"
puts $fout [cat $f]
}
}
}
###
# Script to build the VFS file system
###
proc copyDir {d1 d2} {
puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \
[file tail $d2]]
file delete -force -- $d2
file mkdir $d2
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
copyDir $f [file join $d2 $ftail]
} elseif {[file isfile $f]} {
file copy -force $f [file join $d2 $ftail]
if {$::tcl_platform(platform) eq {unix}} {
file attributes [file join $d2 $ftail] -permissions 0o644
} else {
file attributes [file join $d2 $ftail] -readonly 1
}
}
}
if {$::tcl_platform(platform) eq {unix}} {
file attributes $d2 -permissions 0o755
} else {
file attributes $d2 -readonly 1
}
}
if {[llength $argv] < 3} {
puts "Usage: VFS_ROOT TCLSRC_ROOT PLATFORM"
exit 1
}
set TCL_SCRIPT_DIR [lindex $argv 0]
set TCLSRC_ROOT [lindex $argv 1]
set PLATFORM [lindex $argv 2]
set TKDLL [lindex $argv 3]
set TKVER [lindex $argv 4]
puts "Building [file tail $TCL_SCRIPT_DIR] for $PLATFORM"
copyDir ${TCLSRC_ROOT}/library ${TCL_SCRIPT_DIR}
if {$PLATFORM == "windows"} {
set ddedll [glob -nocomplain ${TCLSRC_ROOT}/win/tcldde*.dll]
puts "DDE DLL $ddedll"
if {$ddedll != {}} {
file copy $ddedll ${TCL_SCRIPT_DIR}/dde
}
set regdll [glob -nocomplain ${TCLSRC_ROOT}/win/tclreg*.dll]
puts "REG DLL $ddedll"
if {$regdll != {}} {
file copy $regdll ${TCL_SCRIPT_DIR}/reg
}
} else {
# Remove the dde and reg package paths
file delete -force ${TCL_SCRIPT_DIR}/dde
file delete -force ${TCL_SCRIPT_DIR}/reg
}
|
| ︙ | ︙ |
Changes to tools/mkdepend.tcl.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
#
# Results:
# None.
proc closeOutput {} {
global output
if {[string match stdout $output] != 0} {
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
#
# Results:
# None.
proc closeOutput {} {
global output
if {[string match stdout $output] != 0} {
close $output
}
}
# readDepends --
#
# Read off CCP pipe for #line references.
#
# Arguments:
# chan The pipe channel we are reading in.
#
# Results:
# Raw dependency list pairs.
proc readDepends {chan} {
set line ""
array set depends {}
while {[gets $chan line] >= 0} {
if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} {
set fname [file normalize $fname]
if {![info exists target]} {
# this is ourself
set target $fname
puts stderr "processing [file tail $fname]"
} else {
# don't include ourselves as a dependency of ourself.
if {![string compare $fname $target]} {continue}
# store in an array so multiple occurrences are not counted.
set depends($target|$fname) ""
}
}
}
set result {}
foreach n [array names depends] {
set pair [split $n "|"]
lappend result [list [lindex $pair 0] [lindex $pair 1]]
}
return $result
}
# writeDepends --
#
# Write the processed list out to the file.
#
# Arguments:
# out The channel to write to.
# depends The list of dependency pairs
#
# Results:
# None.
proc writeDepends {out depends} {
foreach pair $depends {
puts $out "[lindex $pair 0] : \\\n\t[join [lindex $pair 1] " \\\n\t"]"
}
}
# stringStartsWith --
#
# Compares second string to the beginning of the first.
#
# Arguments:
# str The string to test the beginning of.
# prefix The string to test against
#
# Results:
# the result of the comparison.
proc stringStartsWith {str prefix} {
set front [string range $str 0 [expr {[string length $prefix] - 1}]]
return [expr {[string compare [string tolower $prefix] \
[string tolower $front]] == 0}]
}
# filterExcludes --
#
# Remove non-project header files.
#
# Arguments:
# depends List of dependency pairs.
# excludes List of directories that should be removed
#
# Results:
# the processed dependency list.
proc filterExcludes {depends excludes} {
set filtered {}
foreach pair $depends {
set excluded 0
set file [lindex $pair 1]
foreach dir $excludes {
if [stringStartsWith $file $dir] {
set excluded 1
break;
}
}
if {!$excluded} {
lappend filtered $pair
}
}
return $filtered
}
# replacePrefix --
#
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
#
# Results:
# The processed dependency pair list.
proc rebaseFiles {depends} {
set rebased {}
foreach pair $depends {
| | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
#
# Results:
# The processed dependency pair list.
proc rebaseFiles {depends} {
set rebased {}
foreach pair $depends {
lappend rebased [list \
[replacePrefix [lindex $pair 0]] \
[replacePrefix [lindex $pair 1]]]
}
return $rebased
}
# compressDeps --
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
foreach pair $depends {
lappend compressed([lindex $pair 0]) [lindex $pair 1]
}
set result [list]
foreach n [array names compressed] {
| | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
foreach pair $depends {
lappend compressed([lindex $pair 0]) [lindex $pair 1]
}
set result [list]
foreach n [array names compressed] {
lappend result [list $n [lsort $compressed($n)]]
}
return $result
}
# addSearchPath --
#
|
| ︙ | ︙ |
Changes to tools/regexpTestLib.tcl.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
lappend newLs $newItem
}
return $newLs
}
proc convertErrCode {code} {
| | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
lappend newLs $newItem
}
return $newLs
}
proc convertErrCode {code} {
set errMsg "cannot compile regular expression pattern:"
if {[string compare $code "INVARG"] == 0} {
return "$errMsg invalid argument to regex routine"
} elseif {[string compare $code "BADRPT"] == 0} {
return "$errMsg ?+* follows nothing"
} elseif {[string compare $code "BADBR"] == 0} {
return "$errMsg invalid repetition count(s)"
|
| ︙ | ︙ |
Changes to tools/tclOOScript.tcl.
1 2 | # tclOOScript.h -- # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # tclOOScript.h -- # # This file contains support scripts for TclOO. They are defined here so # that the code can be definitely run even in safe interpreters; TclOO's # core setup is safe. # # Copyright © 2012-2019 Donal K. Fellows # Copyright © 2013 Andreas Kupries # Copyright © 2017 Gerald Lester # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
foreach link $args {
if {[llength $link] == 2} {
lassign $link src dst
} elseif {[llength $link] == 1} {
lassign $link src
set dst $src
} else {
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
foreach link $args {
if {[llength $link] == 2} {
lassign $link src dst
} elseif {[llength $link] == 1} {
lassign $link src
set dst $src
} else {
return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
"bad link description; must only have one or two elements"
}
if {![string match ::* $src]} {
set src [string cat $ns :: $src]
}
interp alias {} $src {} ${ns}::my $dst
trace add command ${ns}::my delete [list \
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
# Note that the ::oo::define namespace is semi-public and a bit weird
# anyway, so we don't regard the namespace path as being under control:
# fully qualified names are used for everything.
#
# ----------------------------------------------------------------------
proc define::classmethod {name args} {
| | | | | | | | | | | | | | | | 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 |
# Note that the ::oo::define namespace is semi-public and a bit weird
# anyway, so we don't regard the namespace path as being under control:
# fully qualified names are used for everything.
#
# ----------------------------------------------------------------------
proc define::classmethod {name args} {
# Create the method on the class if the caller gave arguments and body
::set argc [::llength [::info level 0]]
::if {$argc == 3} {
::return -code error -errorcode {TCL WRONGARGS} [::format \
{wrong # args: should be "%s name ?args body?"} \
[::lindex [::info level 0] 0]]
}
::set cls [::uplevel 1 self]
::if {$argc == 4} {
::oo::define [::oo::DelegateName $cls] method $name {*}$args
}
# Make the connection by forwarding
::tailcall forward $name myclass $name
}
# ----------------------------------------------------------------------
#
# oo::define::initialise, oo::define::initialize --
#
# Do specific initialisation for a class. See define(n) for details.
#
# Note that the ::oo::define namespace is semi-public and a bit weird
# anyway, so we don't regard the namespace path as being under control:
# fully qualified names are used for everything.
#
# ----------------------------------------------------------------------
proc define::initialise {body} {
::set clsns [::info object namespace [::uplevel 1 self]]
::tailcall apply [::list {} $body $clsns]
}
# Make the [initialise] definition appear as [initialize] too
namespace eval define {
::namespace export initialise
::namespace eval tmp {::namespace import ::oo::define::initialise}
::namespace export -clear
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
# Basic slot getter. Retrieves the contents of the slot.
# Particular slots must provide concrete non-erroring
# implementation.
#
# ------------------------------------------------------------------
method Get -unexport {} {
| | | | 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 |
# Basic slot getter. Retrieves the contents of the slot.
# Particular slots must provide concrete non-erroring
# implementation.
#
# ------------------------------------------------------------------
method Get -unexport {} {
return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
}
# ------------------------------------------------------------------
#
# Slot Set --
#
# Basic slot setter. Sets the contents of the slot. Particular
# slots must provide concrete non-erroring implementation.
#
# ------------------------------------------------------------------
method Set -unexport list {
return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
}
# ------------------------------------------------------------------
#
# Slot Resolve --
#
# Helper that lets a slot convert a list of arguments of a
|
| ︙ | ︙ | |||
427 428 429 430 431 432 433 |
variable object
unexport create createWithNamespace
method new args {
if {![info exists object] || ![info object isa object $object]} {
set object [next {*}$args]
::oo::objdefine $object {
method destroy {} {
| | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
variable object
unexport create createWithNamespace
method new args {
if {![info exists object] || ![info object isa object $object]} {
set object [next {*}$args]
::oo::objdefine $object {
method destroy {} {
::return -code error -errorcode {TCL OO SINGLETON} \
"may not destroy a singleton object"
}
method <cloned> -unexport {originObject} {
::return -code error -errorcode {TCL OO SINGLETON} \
"may not clone a singleton object"
}
}
}
return $object
}
}
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 |
# Also includes the commands:
#
# * readableproperties
# * writableproperties
# * objreadableproperties
# * objwritableproperties
#
| | > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
# Also includes the commands:
#
# * readableproperties
# * writableproperties
# * objreadableproperties
# * objwritableproperties
#
# These are all slot implementations that provide access to the C layer
# of property support (i.e., very fast cached lookup of property names).
#
# * StdClassProperties
# * StdObjectPropertes
#
# These cause very fast basic implementation methods for a property
# following the standard model of property implementation naming.
# Property schemes that use other models (such as to be more Tk-like)
# should not use these (or the oo::cconfigurable metaclass).
#
# ----------------------------------------------------------------------
namespace eval configuresupport {
# ------------------------------------------------------------------
#
# oo::configuresupport::configurableclass,
# oo::configuresupport::configurableobject --
#
# Namespaces used as implementation vectors for oo::define and
# oo::objdefine when the class/instance is configurable.
# Note that these also contain commands implemented in C,
# especially the [property] definition command.
#
# ------------------------------------------------------------------
::namespace eval configurableclass {
# Plural alias just in case; deliberately NOT documented!
::proc properties args {::tailcall property {*}$args}
::namespace path ::oo::define
::namespace export property
}
::namespace eval configurableobject {
# Plural alias just in case; deliberately NOT documented!
::proc properties args {::tailcall property {*}$args}
::namespace path ::oo::objdefine
::namespace export property
}
# ------------------------------------------------------------------
#
# oo::configuresupport::configurable --
#
# The class that contains the implementation of the actual
# 'configure' method (mixed into actually configurable classes).
# The 'configure' method is in tclOOBasic.c.
#
# ------------------------------------------------------------------
::oo::define configurable {
definitionnamespace -instance configurableobject
definitionnamespace -class configurableclass
}
}
# ----------------------------------------------------------------------
#
|
| ︙ | ︙ |
Changes to tools/tclZIC.tcl.
| ︙ | ︙ | |||
1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 |
puts "creating directory: $dirName"
file mkdir $dirName
}
# Generate data for a zone
set data ""
foreach {
time offset dst name
} [processTimeZone $zoneName $zones($zoneName)] {
append data "\n " [list [list $time $offset $dst $name]]
}
append data \n
# Write the data to the information file
set f [open $fileName w]
| > > > > > > > > > > > > > > | 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 |
puts "creating directory: $dirName"
file mkdir $dirName
}
# Generate data for a zone
set data ""
set tzmapped {}
foreach {
time offset dst name
} [processTimeZone $zoneName $zones($zoneName)] {
if {$name eq "%z"} {
# map %z to pure offset zone (e. g. offset -7200 -> -0200):
set name [format "%+03d%02d" [expr {
$offset / 60 / 60
}] [expr {
(abs($offset) / 60) % 60
}]
]
if {![dict exists $tzmapped $offset]} { # output once per offs
puts "\tmap %z ($offset) -> $name"
dict set tzmapped $offset $name
}
}
append data "\n " [list [list $time $offset $dst $name]]
}
append data \n
# Write the data to the information file
set f [open $fileName w]
|
| ︙ | ︙ | |||
1329 1330 1331 1332 1333 1334 1335 | #---------------------------------------------------------------------- # # MAIN PROGRAM # #---------------------------------------------------------------------- puts "Compiling time zones -- [clock format [clock seconds] \ | | | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 |
#----------------------------------------------------------------------
#
# MAIN PROGRAM
#
#----------------------------------------------------------------------
puts "Compiling time zones -- [clock format [clock seconds] \
-format {%x %X} -locale system]"
# Determine directories
lassign $argv inDir outDir
puts "Olson files in $inDir"
puts "Tcl files to be placed in $outDir"
|
| ︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
1 2 3 4 5 6 |
#!/usr/bin/env tclsh
if {[catch {package require Tcl 8.6-} msg]} {
puts stderr "ERROR: $msg"
puts stderr "If running this script from 'make html', set the\
NATIVE_TCLSH environment\nvariable to point to an installed\
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
#!/usr/bin/env tclsh
if {[catch {package require Tcl 8.6-} msg]} {
puts stderr "ERROR: $msg"
puts stderr "If running this script from 'make html', set the\
NATIVE_TCLSH environment\nvariable to point to an installed\
tclsh9.0 (or the equivalent tclsh90.exe\non Windows)."
exit 1
}
# Convert Ousterhout format man pages into highly crosslinked hypertext.
#
# Along the way detect many unmatched font changes and other odd things.
#
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
wide() mathfunc
packagens pkg::create
pkgMkIndex pkg_mkIndex
pkg_mkIndex pkg_mkIndex
Tcl_Obj Tcl_NewObj
Tcl_ObjType Tcl_RegisterObjType
Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
| | | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 |
wide() mathfunc
packagens pkg::create
pkgMkIndex pkg_mkIndex
pkg_mkIndex pkg_mkIndex
Tcl_Obj Tcl_NewObj
Tcl_ObjType Tcl_RegisterObjType
Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
errorinfo env
errorcode env
tcl_pkgpath env
Tcl_Command Tcl_CreateObjCommand
Tcl_CmdProc Tcl_CreateObjCommand
Tcl_CmdDeleteProc Tcl_CreateObjCommand
Tcl_ObjCmdProc Tcl_CreateObjCommand
Tcl_Channel Tcl_OpenFileChannel
Tcl_WideInt Tcl_NewIntObj
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
1 2 3 4 5 6 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ #-------------------------------------------------------------------------- # Things you can change to personalize the Makefile for your own site (you can # make these changes in either Makefile.in or Makefile, but changes to |
| ︙ | ︙ | |||
297 298 299 300 301 302 303 | XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \ tclTestABSList.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \ | | > | | | | | 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 | XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \ tclTestABSList.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \ tclCkalloc.o tclClock.o tclClockFmt.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ tclEncoding.o tclEnsemble.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o \ tclIcu.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o tclStrIdxTree.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ tclTomMathInterface.o tclZipfs.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOProp.o tclOOStubInit.o TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \ bn_s_mp_sqr_fast.o bn_mp_add.o bn_mp_and.o \ bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \ bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_copy.o \ bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_s_mp_div_3.o bn_mp_exch.o bn_mp_expt_n.o \ bn_mp_get_mag_u64.o \ bn_mp_grow.o bn_mp_init.o \ bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \ bn_mp_init_size.o bn_s_mp_karatsuba_mul.o \ bn_mp_init_i64.o bn_mp_init_u64.o \ bn_s_mp_karatsuba_sqr.o bn_s_mp_balance_mul.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ |
| ︙ | ︙ | |||
407 408 409 410 411 412 413 414 415 416 417 418 419 420 | $(GENERIC_DIR)/tclArithSeries.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ $(GENERIC_DIR)/tclCkalloc.c \ $(GENERIC_DIR)/tclClock.c \ $(GENERIC_DIR)/tclCmdAH.c \ $(GENERIC_DIR)/tclCmdIL.c \ $(GENERIC_DIR)/tclCmdMZ.c \ $(GENERIC_DIR)/tclCompCmds.c \ $(GENERIC_DIR)/tclCompCmdsGR.c \ $(GENERIC_DIR)/tclCompCmdsSZ.c \ $(GENERIC_DIR)/tclCompExpr.c \ | > | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 | $(GENERIC_DIR)/tclArithSeries.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ $(GENERIC_DIR)/tclCkalloc.c \ $(GENERIC_DIR)/tclClock.c \ $(GENERIC_DIR)/tclClockFmt.c \ $(GENERIC_DIR)/tclCmdAH.c \ $(GENERIC_DIR)/tclCmdIL.c \ $(GENERIC_DIR)/tclCmdMZ.c \ $(GENERIC_DIR)/tclCompCmds.c \ $(GENERIC_DIR)/tclCompCmdsGR.c \ $(GENERIC_DIR)/tclCompCmdsSZ.c \ $(GENERIC_DIR)/tclCompExpr.c \ |
| ︙ | ︙ | |||
429 430 431 432 433 434 435 436 437 438 439 440 441 442 | $(GENERIC_DIR)/tclEvent.c \ $(GENERIC_DIR)/tclExecute.c \ $(GENERIC_DIR)/tclFCmd.c \ $(GENERIC_DIR)/tclFileName.c \ $(GENERIC_DIR)/tclGet.c \ $(GENERIC_DIR)/tclHash.c \ $(GENERIC_DIR)/tclHistory.c \ $(GENERIC_DIR)/tclIndexObj.c \ $(GENERIC_DIR)/tclInterp.c \ $(GENERIC_DIR)/tclIO.c \ $(GENERIC_DIR)/tclIOCmd.c \ $(GENERIC_DIR)/tclIOGT.c \ $(GENERIC_DIR)/tclIOSock.c \ $(GENERIC_DIR)/tclIOUtil.c \ | > | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 | $(GENERIC_DIR)/tclEvent.c \ $(GENERIC_DIR)/tclExecute.c \ $(GENERIC_DIR)/tclFCmd.c \ $(GENERIC_DIR)/tclFileName.c \ $(GENERIC_DIR)/tclGet.c \ $(GENERIC_DIR)/tclHash.c \ $(GENERIC_DIR)/tclHistory.c \ $(GENERIC_DIR)/tclIcu.c \ $(GENERIC_DIR)/tclIndexObj.c \ $(GENERIC_DIR)/tclInterp.c \ $(GENERIC_DIR)/tclIO.c \ $(GENERIC_DIR)/tclIOCmd.c \ $(GENERIC_DIR)/tclIOGT.c \ $(GENERIC_DIR)/tclIOSock.c \ $(GENERIC_DIR)/tclIOUtil.c \ |
| ︙ | ︙ | |||
462 463 464 465 466 467 468 469 470 471 472 473 474 475 | $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestABSList.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ | > | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 | $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrIdxTree.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestABSList.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ |
| ︙ | ︙ | |||
486 487 488 489 490 491 492 493 494 495 496 497 498 499 | OO_SRCS = \ $(GENERIC_DIR)/tclOO.c \ $(GENERIC_DIR)/tclOOBasic.c \ $(GENERIC_DIR)/tclOOCall.c \ $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclOOMethod.c \ $(GENERIC_DIR)/tclOOStubInit.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStubCall.c \ $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ | > | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 | OO_SRCS = \ $(GENERIC_DIR)/tclOO.c \ $(GENERIC_DIR)/tclOOBasic.c \ $(GENERIC_DIR)/tclOOCall.c \ $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclOOMethod.c \ $(GENERIC_DIR)/tclOOProp.c \ $(GENERIC_DIR)/tclOOStubInit.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStubCall.c \ $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ |
| ︙ | ︙ | |||
518 519 520 521 522 523 524 | $(TOMMATH_DIR)/bn_mp_complement.c \ $(TOMMATH_DIR)/bn_mp_copy.c \ $(TOMMATH_DIR)/bn_mp_count_bits.c \ $(TOMMATH_DIR)/bn_mp_decr.c \ $(TOMMATH_DIR)/bn_mp_div.c \ $(TOMMATH_DIR)/bn_mp_div_2.c \ $(TOMMATH_DIR)/bn_mp_div_2d.c \ | | | < < < < | > > > | 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 | $(TOMMATH_DIR)/bn_mp_complement.c \ $(TOMMATH_DIR)/bn_mp_copy.c \ $(TOMMATH_DIR)/bn_mp_count_bits.c \ $(TOMMATH_DIR)/bn_mp_decr.c \ $(TOMMATH_DIR)/bn_mp_div.c \ $(TOMMATH_DIR)/bn_mp_div_2.c \ $(TOMMATH_DIR)/bn_mp_div_2d.c \ $(TOMMATH_DIR)/bn_s_mp_div_3.c \ $(TOMMATH_DIR)/bn_mp_div_d.c \ $(TOMMATH_DIR)/bn_mp_dr_is_modulus.c \ $(TOMMATH_DIR)/bn_mp_dr_reduce.c \ $(TOMMATH_DIR)/bn_mp_dr_setup.c \ $(TOMMATH_DIR)/bn_mp_error_to_string.c \ $(TOMMATH_DIR)/bn_mp_exch.c \ $(TOMMATH_DIR)/bn_mp_expt_n.c \ $(TOMMATH_DIR)/bn_mp_exptmod.c \ $(TOMMATH_DIR)/bn_mp_exteuclid.c \ $(TOMMATH_DIR)/bn_mp_fread.c \ $(TOMMATH_DIR)/bn_mp_from_sbin.c \ $(TOMMATH_DIR)/bn_mp_from_ubin.c \ $(TOMMATH_DIR)/bn_mp_fwrite.c \ $(TOMMATH_DIR)/bn_mp_gcd.c \ $(TOMMATH_DIR)/bn_mp_get_double.c \ $(TOMMATH_DIR)/bn_mp_get_i32.c \ $(TOMMATH_DIR)/bn_mp_get_i64.c \ $(TOMMATH_DIR)/bn_mp_get_l.c \ $(TOMMATH_DIR)/bn_mp_get_mag_u32.c \ $(TOMMATH_DIR)/bn_mp_get_mag_u64.c \ $(TOMMATH_DIR)/bn_mp_get_mag_ul.c \ $(TOMMATH_DIR)/bn_mp_grow.c \ $(TOMMATH_DIR)/bn_mp_incr.c \ $(TOMMATH_DIR)/bn_mp_init.c \ $(TOMMATH_DIR)/bn_mp_init_copy.c \ $(TOMMATH_DIR)/bn_mp_init_i32.c \ $(TOMMATH_DIR)/bn_mp_init_i64.c \ $(TOMMATH_DIR)/bn_mp_init_l.c \ $(TOMMATH_DIR)/bn_mp_init_multi.c \ $(TOMMATH_DIR)/bn_mp_init_set.c \ $(TOMMATH_DIR)/bn_mp_init_size.c \ $(TOMMATH_DIR)/bn_mp_init_u32.c \ $(TOMMATH_DIR)/bn_mp_init_u64.c \ $(TOMMATH_DIR)/bn_mp_init_ul.c \ $(TOMMATH_DIR)/bn_mp_invmod.c \ $(TOMMATH_DIR)/bn_mp_is_square.c \ $(TOMMATH_DIR)/bn_mp_iseven.c \ $(TOMMATH_DIR)/bn_mp_isodd.c \ $(TOMMATH_DIR)/bn_mp_kronecker.c \ $(TOMMATH_DIR)/bn_mp_lcm.c \ $(TOMMATH_DIR)/bn_mp_log_n.c \ $(TOMMATH_DIR)/bn_s_mp_log.c \ $(TOMMATH_DIR)/bn_s_mp_log_2expt.c \ $(TOMMATH_DIR)/bn_s_mp_log_d.c \ $(TOMMATH_DIR)/bn_mp_lshd.c \ $(TOMMATH_DIR)/bn_mp_mod.c \ $(TOMMATH_DIR)/bn_mp_mod_2d.c \ $(TOMMATH_DIR)/bn_mp_mod_d.c \ $(TOMMATH_DIR)/bn_mp_montgomery_calc_normalization.c \ $(TOMMATH_DIR)/bn_mp_montgomery_reduce.c \ $(TOMMATH_DIR)/bn_mp_montgomery_setup.c \ |
| ︙ | ︙ | |||
600 601 602 603 604 605 606 | $(TOMMATH_DIR)/bn_mp_reduce_2k.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_setup.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_setup_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_is_2k.c \ $(TOMMATH_DIR)/bn_mp_reduce_is_2k_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_setup.c \ | | < < | 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 | $(TOMMATH_DIR)/bn_mp_reduce_2k.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_setup.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_setup_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_is_2k.c \ $(TOMMATH_DIR)/bn_mp_reduce_is_2k_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_setup.c \ $(TOMMATH_DIR)/bn_mp_root_n.c \ $(TOMMATH_DIR)/bn_mp_rshd.c \ $(TOMMATH_DIR)/bn_mp_sbin_size.c \ $(TOMMATH_DIR)/bn_mp_set.c \ $(TOMMATH_DIR)/bn_mp_set_double.c \ $(TOMMATH_DIR)/bn_mp_set_i32.c \ $(TOMMATH_DIR)/bn_mp_set_i64.c \ $(TOMMATH_DIR)/bn_mp_set_l.c \ $(TOMMATH_DIR)/bn_mp_set_u32.c \ $(TOMMATH_DIR)/bn_mp_set_u64.c \ $(TOMMATH_DIR)/bn_mp_set_ul.c \ $(TOMMATH_DIR)/bn_mp_shrink.c \ $(TOMMATH_DIR)/bn_mp_signed_rsh.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_sqrmod.c \ $(TOMMATH_DIR)/bn_mp_sqrt.c \ $(TOMMATH_DIR)/bn_mp_sqrtmod_prime.c \ $(TOMMATH_DIR)/bn_mp_sub.c \ |
| ︙ | ︙ | |||
801 802 803 804 805 806 807 |
${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
rm -f $@
@MAKE_LIB@
@if test "${ZIPFS_BUILD}" = "1" ; then \
if test "x$(MACHER)" = "x" ; then \
cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
else $(MACHER) append ${LIB_FILE} ${TCL_ZIP_FILE} /tmp/macher_output; \
| | < < | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
rm -f $@
@MAKE_LIB@
@if test "${ZIPFS_BUILD}" = "1" ; then \
if test "x$(MACHER)" = "x" ; then \
cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
else $(MACHER) append ${LIB_FILE} ${TCL_ZIP_FILE} /tmp/macher_output; \
mv /tmp/macher_output ${LIB_FILE}; chmod u+x ${LIB_FILE}; \
fi; \
fi
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
@if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \
( cd ${TOP_DIR}/win; ${MAKE} winextensions ); \
fi
rm -f $@
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 |
${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCL_EXE}
@if test "${ZIPFS_BUILD}" = "2" ; then \
if test "x$(MACHER)" = "x" ; then \
cat ${TCL_ZIP_FILE} >> ${TCL_EXE}; \
else $(MACHER) append ${TCL_EXE} ${TCL_ZIP_FILE} /tmp/macher_output; \
| | < < | 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 |
${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCL_EXE}
@if test "${ZIPFS_BUILD}" = "2" ; then \
if test "x$(MACHER)" = "x" ; then \
cat ${TCL_ZIP_FILE} >> ${TCL_EXE}; \
else $(MACHER) append ${TCL_EXE} ${TCL_ZIP_FILE} /tmp/macher_output; \
mv /tmp/macher_output ${TCL_EXE}; chmod u+x ${TCL_EXE}; \
fi; \
fi
# Must be empty so it doesn't conflict with rule for ${TCL_EXE} above
${NATIVE_TCLSH}:
Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
$(SHELL) config.status
|
| ︙ | ︙ | |||
895 896 897 898 899 900 901 |
${CC} ${CFLAGS} ${LDFLAGS} ${TCLTEST_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCLTEST_EXE}
@if test "${ZIPFS_BUILD}" = "2" ; then \
if test "x$(MACHER)" = "x" ; then \
cat ${TCL_ZIP_FILE} >> ${TCLTEST_EXE}; \
else $(MACHER) append ${TCLTEST_EXE} ${TCL_ZIP_FILE} /tmp/macher_output; \
| | < < | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 |
${CC} ${CFLAGS} ${LDFLAGS} ${TCLTEST_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCLTEST_EXE}
@if test "${ZIPFS_BUILD}" = "2" ; then \
if test "x$(MACHER)" = "x" ; then \
cat ${TCL_ZIP_FILE} >> ${TCLTEST_EXE}; \
else $(MACHER) append ${TCLTEST_EXE} ${TCL_ZIP_FILE} /tmp/macher_output; \
mv /tmp/macher_output ${TCLTEST_EXE}; chmod u+x ${TCLTEST_EXE}; \
fi; \
fi
# Note, in the targets below TCL_LIBRARY needs to be set or else "make test"
# won't work in the case where the compilation directory isn't the same as the
# source directory.
#
# Specifying TESTFLAGS on the command line is the standard way to pass args to
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 | @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/" @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/" @for i in $(TOP_DIR)/library/cookiejar/*.tcl \ | | | | | | | | | 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 |
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \
$(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done;
@echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/"
@for i in $(TOP_DIR)/library/cookiejar/*.tcl \
$(TOP_DIR)/library/cookiejar/*.gz; \
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
@echo "Installing package http 2.10.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
"$(MODULE_INSTALL_DIR)/9.0/http-2.10.0.tm"
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"
@for i in $(TOP_DIR)/library/opt/*.tcl; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done
@echo "Installing package msgcat 1.7.1 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
"$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm"
@echo "Installing package tcltest 2.5.9 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
"$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.9.tm"
@echo "Installing package platform 1.0.19 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)/9.0/platform-1.0.19.tm"
@echo "Installing package platform::shell 1.1.4 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \
"$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm"
@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"
@for i in $(TOP_DIR)/library/encoding/*.enc; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \
done
@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \
echo "Customizing tcl module path"; \
echo "if {![interp issafe]} { ::tcl::tm::roots [list $(TCL_MODULE_PATH)] }" >> \
"$(SCRIPT_INSTALL_DIR)/tm.tcl"; \
fi
install-tzdata:
@for i in tzdata; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
|
| ︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 |
MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h
PARSEHDR = $(GENERIC_DIR)/tclParse.h
NREHDR = $(GENERIC_DIR)/tclInt.h
TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
$(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c
regexec.o: $(REGHDRS) $(GENERIC_DIR)/regexec.c $(GENERIC_DIR)/rege_dfa.c
| > | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h
PARSEHDR = $(GENERIC_DIR)/tclParse.h
NREHDR = $(GENERIC_DIR)/tclInt.h
TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
TCLDATEHDR=$(GENERIC_DIR)/tclDate.h $(GENERIC_DIR)/tclStrIdxTree.h
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
$(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c
regexec.o: $(REGHDRS) $(GENERIC_DIR)/regexec.c $(GENERIC_DIR)/rege_dfa.c
|
| ︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 | tclBinary.o: $(GENERIC_DIR)/tclBinary.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c | | > > > | | 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 | tclBinary.o: $(GENERIC_DIR)/tclBinary.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c tclClock.o: $(GENERIC_DIR)/tclClock.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c tclClockFmt.o: $(GENERIC_DIR)/tclClockFmt.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClockFmt.c tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c tclDate.o: $(GENERIC_DIR)/tclDate.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c |
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 | tclHash.o: $(GENERIC_DIR)/tclHash.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHash.c tclHistory.o: $(GENERIC_DIR)/tclHistory.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHistory.c tclIndexObj.o: $(GENERIC_DIR)/tclIndexObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIndexObj.c tclInterp.o: $(GENERIC_DIR)/tclInterp.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclInterp.c tclIO.o: $(GENERIC_DIR)/tclIO.c $(IOHDR) | > > > | 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 | tclHash.o: $(GENERIC_DIR)/tclHash.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHash.c tclHistory.o: $(GENERIC_DIR)/tclHistory.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHistory.c tclIcu.o: $(GENERIC_DIR)/tclIcu.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIcu.c tclIndexObj.o: $(GENERIC_DIR)/tclIndexObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIndexObj.c tclInterp.o: $(GENERIC_DIR)/tclInterp.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclInterp.c tclIO.o: $(GENERIC_DIR)/tclIO.c $(IOHDR) |
| ︙ | ︙ | |||
1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 | tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOInfo.c tclOOMethod.o: $(GENERIC_DIR)/tclOOMethod.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOMethod.c tclOOStubInit.o: $(GENERIC_DIR)/tclOOStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOStubInit.c tclParse.o: $(GENERIC_DIR)/tclParse.c $(PARSEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c tclPanic.o: $(GENERIC_DIR)/tclPanic.c | > > > | 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 | tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOInfo.c tclOOMethod.o: $(GENERIC_DIR)/tclOOMethod.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOMethod.c tclOOProp.o: $(GENERIC_DIR)/tclOOProp.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOProp.c tclOOStubInit.o: $(GENERIC_DIR)/tclOOStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOStubInit.c tclParse.o: $(GENERIC_DIR)/tclParse.c $(PARSEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c tclPanic.o: $(GENERIC_DIR)/tclPanic.c |
| ︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResult.c tclScan.o: $(GENERIC_DIR)/tclScan.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c tclStrToD.o: $(GENERIC_DIR)/tclStrToD.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrToD.c tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c | > > > | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResult.c tclScan.o: $(GENERIC_DIR)/tclScan.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c tclStrIdxTree.o: $(GENERIC_DIR)/tclStrIdxTree.c $(GENERIC_DIR)/tclStrIdxTree.h $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrIdxTree.c tclStrToD.o: $(GENERIC_DIR)/tclStrToD.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrToD.c tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c |
| ︙ | ︙ | |||
1652 1653 1654 1655 1656 1657 1658 | bn_mp_div_2.o: $(TOMMATH_DIR)/bn_mp_div_2.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2.c bn_mp_div_2d.o: $(TOMMATH_DIR)/bn_mp_div_2d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2d.c | | | | | | 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 | bn_mp_div_2.o: $(TOMMATH_DIR)/bn_mp_div_2.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2.c bn_mp_div_2d.o: $(TOMMATH_DIR)/bn_mp_div_2d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2d.c bn_s_mp_div_3.o: $(TOMMATH_DIR)/bn_s_mp_div_3.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_div_3.c bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c bn_mp_expt_n.o: $(TOMMATH_DIR)/bn_mp_expt_n.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_n.c bn_mp_get_mag_u64.o: $(TOMMATH_DIR)/bn_mp_get_mag_u64.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_mag_u64.c bn_mp_grow.o: $(TOMMATH_DIR)/bn_mp_grow.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_grow.c |
| ︙ | ︙ | |||
2314 2315 2316 2317 2318 2319 2320 |
printf "unknown" >$(TOP_DIR)/manifest.uuid)
dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \
$(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH}
rm -rf $(DISTDIR)
$(INSTALL_DATA_DIR) $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(TOP_DIR)/manifest.uuid $(DISTDIR)
| | | | 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 |
printf "unknown" >$(TOP_DIR)/manifest.uuid)
dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \
$(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH}
rm -rf $(DISTDIR)
$(INSTALL_DATA_DIR) $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(TOP_DIR)/manifest.uuid $(DISTDIR)
$(DIST_INSTALL_DATA) $(UNIX_DIR)/*.c $(UNIX_DIR)/tclUnixPort.h $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
$(DIST_INSTALL_DATA) $(UNIX_DIR)/configure.ac \
$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
$(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/tclooConfig.sh \
$(UNIX_DIR)/install-sh \
$(UNIX_DIR)/README $(UNIX_DIR)/tcl.spec \
$(UNIX_DIR)/installManPage $(UNIX_DIR)/tclConfig.h.in \
$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
$(DIST_INSTALL_SCRIPT) $(UNIX_DIR)/configure $(UNIX_DIR)/ldAix $(DISTDIR)/unix
$(INSTALL_DATA_DIR) $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/README $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
$(DIST_INSTALL_DATA) $(TOP_DIR)/changes.md $(TOP_DIR)/README.md \
$(TOP_DIR)/license.terms $(DISTDIR)
$(INSTALL_DATA_DIR) $(DISTDIR)/library
$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
$(TOP_DIR)/library/manifest.txt \
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
@for i in $(BUILTIN_PACKAGE_LIST); do \
$(INSTALL_DATA_DIR) $(DISTDIR)/library/$$i;\
|
| ︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 | | ( 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 \ | | | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 | | ( 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/*.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; |
| ︙ | ︙ | |||
2403 2404 2405 2406 2407 2408 2409 | $(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 \ $(TOP_DIR)/win/x86_64-w64-mingw32-nmakehlp.exe $(DISTDIR)/win chmod 775 $(DISTDIR)/win/x86_64-w64-mingw32-nmakehlp.exe $(DIST_INSTALL_SCRIPT) $(TOP_DIR)/win/configure $(DISTDIR)/win | | > | < < < < | | > < | 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 | $(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 \ $(TOP_DIR)/win/x86_64-w64-mingw32-nmakehlp.exe $(DISTDIR)/win chmod 775 $(DISTDIR)/win/x86_64-w64-mingw32-nmakehlp.exe $(DIST_INSTALL_SCRIPT) $(TOP_DIR)/win/configure $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(TOP_DIR)/win/tclWinInt.h $(TOP_DIR)/win/tclWinPort.h \ $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.bat $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.vc $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/README $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/win $(INSTALL_DATA_DIR) $(DISTDIR)/macosx $(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac \ $(DISTDIR)/macosx $(DIST_INSTALL_SCRIPT) $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/macosx $(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/addVerToFile.tcl \ $(DISTDIR)/tools/makeTestCases.tcl $(DISTDIR)/tools/tclZIC.tcl \ $(DISTDIR)/tools/tcltk-man2html.tcl $(DISTDIR)/win/buildall.vc.bat \ $(DISTDIR)/unix/install-sh $(DISTDIR)/unix/installManPage $(INSTALL_DATA_DIR) $(DISTDIR)/pkgs $(DIST_INSTALL_DATA) $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs $(DIST_INSTALL_DATA) $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null`; do \ tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ done $(INSTALL_DATA_DIR) $(DISTDIR)/.github/workflows $(DIST_INSTALL_DATA) $(TOP_DIR)/.github/workflows/*.yml $(DISTDIR)/.github/workflows alldist: dist rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME) ( cd $(DISTROOT); \ tar cf $(DISTNAME)-src.tar $(DISTNAME); \ |
| ︙ | ︙ | |||
2478 2479 2480 2481 2482 2483 2484 |
@EXTRA_BUILD_HTML@
html-tk: ${NATIVE_TCLSH}
$(BUILD_HTML) --tk
@EXTRA_BUILD_HTML@
BUILD_HTML = \
| | | 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 |
@EXTRA_BUILD_HTML@
html-tk: ${NATIVE_TCLSH}
$(BUILD_HTML) --tk
@EXTRA_BUILD_HTML@
BUILD_HTML = \
@${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \
--useversion=$(MAJOR_VERSION).$(MINOR_VERSION) \
--htmldir="$(HTML_INSTALL_DIR)" \
--srcdir=$(TOP_DIR) $(BUILD_HTML_FLAGS)
#--------------------------------------------------------------------------
# The list of all the targets that do not correspond to real files. This stops
# 'make' from getting confused when someone makes an error in a rule.
|
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
2706 2707 2708 2709 2710 2711 2712 | TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 | | | 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 |
TCL_VERSION=9.0
TCL_MAJOR_VERSION=9
TCL_MINOR_VERSION=0
TCL_PATCH_LEVEL=".2"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}
#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
|
| ︙ | ︙ | |||
4252 4253 4254 4255 4256 4257 4258 | else case e in #( e) tcl_ok=0 ;; esac fi rm -rf conftest* | < < < < < < < < < | 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 |
else case e in #(
e) tcl_ok=0 ;;
esac
fi
rm -rf conftest*
ac_fn_c_check_header_compile "$LINENO" "sys/wait.h" "ac_cv_header_sys_wait_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_wait_h" = xyes
then :
else case e in #(
e)
printf "%s\n" "#define NO_SYS_WAIT_H 1" >>confdefs.h
|
| ︙ | ︙ | |||
5200 5201 5202 5203 5204 5205 5206 5207 |
ZLIB_OBJS=\${ZLIB_OBJS}
ZLIB_SRCS=\${ZLIB_SRCS}
ZLIB_INCLUDE=-I\${ZLIB_DIR}
| | < > | 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 |
ZLIB_OBJS=\${ZLIB_OBJS}
ZLIB_SRCS=\${ZLIB_SRCS}
ZLIB_INCLUDE=-I\${ZLIB_DIR}
printf "%s\n" "#define TCL_WITH_INTERNAL_ZLIB 1" >>confdefs.h
fi
#------------------------------------------------------------------------
# Add stuff for libtommath
libtommath_ok=yes
# Check whether --with-system-libtommath was given.
|
| ︙ | ︙ | |||
5789 5790 5791 5792 5793 5794 5795 |
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r|*_r\ *)
# ok ...
;;
*)
# Make sure only first arg gets _r
| | | 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 |
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r|*_r\ *)
# ok ...
;;
*)
# Make sure only first arg gets _r
CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'`
;;
esac
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5
printf "%s\n" "Using $CC for compiling with threads" >&6; }
fi
LIBS="$LIBS -lc"
|
| ︙ | ︙ | |||
6363 6364 6365 6366 6367 6368 6369 | fi # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = yes then : | | | | | | | | | 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 |
fi
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = yes
then :
if test "$GCC" = yes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5
printf "%s\n" "$as_me: WARNING: 64bit mode not supported by gcc" >&2;}
else case e in #(
e)
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
CFLAGS="$CFLAGS -64"
LDFLAGS_ARCH="-64"
;;
esac
fi
fi
;;
Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*)
SHLIB_CFLAGS="-fPIC -fno-common"
|
| ︙ | ︙ | |||
6398 6399 6400 6401 6402 6403 6404 |
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
case $system in
DragonFly-*|FreeBSD-*)
| < < < | | | | < | | 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 |
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
case $system in
DragonFly-*|FreeBSD-*)
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
;;
esac
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
|
| ︙ | ︙ | |||
6702 6703 6704 6705 6706 6707 6708 |
fat_32_64=yes
fi
;;
esac
fi
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 |
fat_32_64=yes
fi
;;
esac
fi
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -headerpad_max_install_names"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5
printf %s "checking if ld accepts -search_paths_first flag... " >&6; }
if test ${tcl_cv_ld_search_paths_first+y}
|
| ︙ | ︙ | |||
6864 6865 6866 6867 6868 6869 6870 |
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
if test "$fat_32_64" = yes
then :
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
| | | 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 |
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
if test "$fat_32_64" = yes
then :
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
done
fi
LIBS=$hold_libs ;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation" >&5
printf "%s\n" "$tcl_cv_lib_corefoundation" >&6; }
if test $tcl_cv_lib_corefoundation = yes
|
| ︙ | ︙ | |||
6929 6930 6931 6932 6933 6934 6935 | printf "%s\n" "$tcl_cv_lib_corefoundation_64" >&6; } if test $tcl_cv_lib_corefoundation_64 = no then : printf "%s\n" "#define NO_COREFOUNDATION_64 1" >>confdefs.h | | | | | 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 |
printf "%s\n" "$tcl_cv_lib_corefoundation_64" >&6; }
if test $tcl_cv_lib_corefoundation_64 = no
then :
printf "%s\n" "#define NO_COREFOUNDATION_64 1" >>confdefs.h
LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings"
fi
fi
fi
;;
OS/390-*)
SHLIB_LD_LIBS=""
CFLAGS_OPTIMIZE="" # Optimizer is buggy
printf "%s\n" "#define _OE_SOCKETS 1" >>confdefs.h
;;
OSF1-V*)
# Digital OSF/1
SHLIB_CFLAGS=""
if test "$SHARED_BUILD" = 1
then :
SHLIB_LD='${CC} -shared'
else case e in #(
e)
SHLIB_LD='${CC} -non_shared'
;;
esac
fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes
|
| ︙ | ︙ | |||
7297 7298 7299 7300 7301 7302 7303 |
tcl_cv_ld_Bexport=yes
else case e in #(
e) tcl_cv_ld_Bexport=no ;;
esac
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
| | | 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 |
tcl_cv_ld_Bexport=yes
else case e in #(
e) tcl_cv_ld_Bexport=no ;;
esac
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LDFLAGS=$hold_ldflags ;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_Bexport" >&5
printf "%s\n" "$tcl_cv_ld_Bexport" >&6; }
if test $tcl_cv_ld_Bexport = yes
then :
|
| ︙ | ︙ | |||
7415 7416 7417 7418 7419 7420 7421 |
UNSHARED_LIB_SUFFIX='${VERSION}.a'
fi
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""
then :
| | | | | | | | | | | | | | | | | | 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 |
UNSHARED_LIB_SUFFIX='${VERSION}.a'
fi
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""
then :
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
if test "${SHLIB_SUFFIX}" = ".dll"
then :
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
else case e in #(
e)
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
;;
esac
fi
else case e in #(
e)
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
if test "$RANLIB" = ""
then :
MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
else case e in #(
e)
MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
;;
esac
fi
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
;;
esac
fi
# Stub lib does not depend on shared/static configuration
if test "$RANLIB" = ""
then :
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
else case e in #(
e)
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
;;
esac
fi
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"'
# Define TCL_LIBS now that we know what DL_LIBS is.
# The trick here is that we don't want to change the value of TCL_LIBS if
# it is already set when tclConfig.sh had been loaded by Tk.
if test "x${TCL_LIBS}" = x
then :
TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"
fi
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
|
| ︙ | ︙ | |||
7918 7919 7920 7921 7922 7923 7924 | printf %s "(cached) " >&6 else case e in #( e) tcl_cv_type_64bit=none # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... | | | | | 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 |
printf %s "(cached) " >&6
else case e in #(
e)
tcl_cv_type_64bit=none
# See if we could use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
switch (0) {
case 1: case (sizeof(long long)==sizeof(long)): ;
}
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_type_64bit="long long"
|
| ︙ | ︙ | |||
8072 8073 8074 8075 8076 8077 8078 |
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
main (void)
{
struct dirent64 *p; DIR64 d = opendir64(".");
| | | 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 |
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
main (void)
{
struct dirent64 *p; DIR64 d = opendir64(".");
p = readdir64(d); rewinddir64(d); closedir64(d);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_DIR64=yes
|
| ︙ | ︙ | |||
8139 8140 8141 8142 8143 8144 8145 |
esac
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
esac
fi
if test "x${tcl_cv_type_off64_t}" = "xyes" && \
| | | | 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 |
esac
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
esac
fi
if test "x${tcl_cv_type_off64_t}" = "xyes" && \
test "x${ac_cv_func_lseek64}" = "xyes" && \
test "x${ac_cv_func_open64}" = "xyes" ; then
printf "%s\n" "#define HAVE_TYPE_OFF64_T 1" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
| ︙ | ︙ | |||
9664 9665 9666 9667 9668 9669 9670 | fi ac_fn_c_check_func "$LINENO" "localtime_r" "ac_cv_func_localtime_r" if test "x$ac_cv_func_localtime_r" = xyes then : printf "%s\n" "#define HAVE_LOCALTIME_R 1" >>confdefs.h | < < < < < < | 9611 9612 9613 9614 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 |
fi
ac_fn_c_check_func "$LINENO" "localtime_r" "ac_cv_func_localtime_r"
if test "x$ac_cv_func_localtime_r" = xyes
then :
printf "%s\n" "#define HAVE_LOCALTIME_R 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking tm_tzadj in struct tm" >&5
printf %s "checking tm_tzadj in struct tm... " >&6; }
if test ${tcl_cv_member_tm_tzadj+y}
then :
|
| ︙ | ︙ | |||
9884 9885 9886 9887 9888 9889 9890 | else case e in #( e) printf "%s\n" "#define NO_FSTATFS 1" >>confdefs.h ;; esac fi | < < < < < < < < < < < < < < < < < < < < < < | 9825 9826 9827 9828 9829 9830 9831 9832 9833 9834 9835 9836 9837 9838 | else case e in #( e) printf "%s\n" "#define NO_FSTATFS 1" >>confdefs.h ;; esac fi #-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- ac_fn_c_check_type "$LINENO" "mode_t" "ac_cv_type_mode_t" "$ac_includes_default" |
| ︙ | ︙ | |||
10013 10014 10015 10016 10017 10018 10019 |
#include <sys/types.h>
#include <sys/socket.h>
int
main (void)
{
| | | 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 |
#include <sys/types.h>
#include <sys/socket.h>
int
main (void)
{
socklen_t foo;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
|
| ︙ | ︙ | |||
10580 10581 10582 10583 10584 10585 10586 |
fi
printf "%s\n" "#define TCL_LOAD_FROM_MEMORY 1" >>confdefs.h
printf "%s\n" "#define TCL_WIDE_CLICKS 1" >>confdefs.h
| < < < < < < < < | | < < < < < < < | | | | | | | < < < < < < < | | | | < | 10499 10500 10501 10502 10503 10504 10505 10506 10507 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 10520 10521 10522 10523 10524 10525 10526 10527 10528 10529 10530 10531 10532 10533 10534 10535 10536 10537 10538 10539 10540 10541 10542 10543 10544 10545 10546 10547 10548 10549 10550 10551 10552 10553 10554 10555 10556 10557 10558 10559 10560 10561 10562 10563 10564 10565 10566 10567 10568 10569 10570 10571 10572 10573 10574 10575 10576 10577 10578 10579 10580 10581 10582 10583 10584 10585 10586 10587 10588 10589 10590 10591 |
fi
printf "%s\n" "#define TCL_LOAD_FROM_MEMORY 1" >>confdefs.h
printf "%s\n" "#define TCL_WIDE_CLICKS 1" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if weak import is available" >&5
printf %s "checking if weak import is available... " >&6; }
if test ${tcl_cv_cc_weak_import+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int rand(void) __attribute__((weak_import));
int
main (void)
{
rand();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_cc_weak_import=yes
else case e in #(
e) tcl_cv_cc_weak_import=no ;;
esac
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags ;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_weak_import" >&5
printf "%s\n" "$tcl_cv_cc_weak_import" >&6; }
if test $tcl_cv_cc_weak_import = yes; then
printf "%s\n" "#define HAVE_WEAK_IMPORT 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if Darwin SUSv3 extensions are available" >&5
printf %s "checking if Darwin SUSv3 extensions are available... " >&6; }
if test ${tcl_cv_cc_darwin_c_source+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _DARWIN_C_SOURCE 1
#include <sys/cdefs.h>
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_cc_darwin_c_source=yes
else case e in #(
e) tcl_cv_cc_darwin_c_source=no ;;
esac
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
CFLAGS=$hold_cflags ;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_darwin_c_source" >&5
printf "%s\n" "$tcl_cv_cc_darwin_c_source" >&6; }
if test $tcl_cv_cc_darwin_c_source = yes; then
printf "%s\n" "#define _DARWIN_C_SOURCE 1" >>confdefs.h
fi
# Build .bundle dltest binaries in addition to .dylib
DLTEST_LD='${CC} -bundle -Wl,-w ${CFLAGS} ${LDFLAGS}'
DLTEST_SUFFIX=".bundle"
else
DLTEST_LD='${SHLIB_LD}'
DLTEST_SUFFIX=""
|
| ︙ | ︙ | |||
11019 11020 11021 11022 11023 11024 11025 |
int
main (void)
{
int index,regsPtr[4];
__asm__ __volatile__("mov %%ebx, %%edi \n\t"
| | | | | | | 10915 10916 10917 10918 10919 10920 10921 10922 10923 10924 10925 10926 10927 10928 10929 10930 10931 10932 10933 |
int
main (void)
{
int index,regsPtr[4];
__asm__ __volatile__("mov %%ebx, %%edi \n\t"
"cpuid \n\t"
"mov %%ebx, %%esi \n\t"
"mov %%edi, %%ebx \n\t"
: "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
: "a"(index) : "edi");
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
|
| ︙ | ︙ | |||
11135 11136 11137 11138 11139 11140 11141 |
# Construct a fake local framework structure to make linking with
# '-framework Tcl' and running of tcltest work
ac_config_commands="$ac_config_commands Tcl.framework"
LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH"
# default install directory for bundled packages
if test "${libdir}" = '${exec_prefix}/lib' -o "`basename ${libdir}`" = 'Frameworks'; then
| | | | | | 11031 11032 11033 11034 11035 11036 11037 11038 11039 11040 11041 11042 11043 11044 11045 11046 11047 11048 11049 11050 11051 |
# Construct a fake local framework structure to make linking with
# '-framework Tcl' and running of tcltest work
ac_config_commands="$ac_config_commands Tcl.framework"
LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH"
# default install directory for bundled packages
if test "${libdir}" = '${exec_prefix}/lib' -o "`basename ${libdir}`" = 'Frameworks'; then
PACKAGE_DIR="/Library/Tcl"
else
PACKAGE_DIR="$libdir"
fi
if test "${libdir}" = '${exec_prefix}/lib'; then
# override libdir default
libdir="/Library/Frameworks"
fi
TCL_LIB_FILE="Tcl"
TCL_LIB_FLAG="-framework Tcl"
TCL_BUILD_LIB_SPEC="-F`pwd | sed -e 's/ /\\\\ /g'` -framework Tcl"
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
|
| ︙ | ︙ | |||
11168 11169 11170 11171 11172 11173 11174 |
EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
# libdir must be a fully qualified path and not ${exec_prefix}/lib
eval libdir="$libdir"
# default install directory for bundled packages
PACKAGE_DIR="$libdir"
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
| | | | 11064 11065 11066 11067 11068 11069 11070 11071 11072 11073 11074 11075 11076 11077 11078 11079 11080 |
EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
# libdir must be a fully qualified path and not ${exec_prefix}/lib
eval libdir="$libdir"
# default install directory for bundled packages
PACKAGE_DIR="$libdir"
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_LIB_FLAG="-ltcl${TCL_VERSION}"
else
TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`"
fi
TCL_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_LIB_FLAG}"
TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
fi
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
|
| ︙ | ︙ | |||
11199 11200 11201 11202 11203 11204 11205 |
if test "$tcl_ok" = "yes" -a "x$enable_framework" != "xyes"; then
#
# Find a native compiler
#
# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 11095 11096 11097 11098 11099 11100 11101 11102 11103 11104 11105 11106 11107 11108 11109 11110 11111 11112 11113 11114 11115 11116 11117 11118 11119 11120 11121 11122 11123 11124 11125 11126 11127 11128 11129 11130 11131 11132 11133 11134 11135 11136 11137 11138 11139 11140 11141 11142 11143 11144 11145 11146 11147 11148 11149 11150 11151 11152 11153 11154 11155 11156 11157 11158 11159 11160 |
if test "$tcl_ok" = "yes" -a "x$enable_framework" != "xyes"; then
#
# Find a native compiler
#
# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
CC_FOR_BUILD='$(CC)'
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5
printf %s "checking for gcc... " >&6; }
if test ${ac_cv_path_cc+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/gcc 2> /dev/null` \
`ls -r $dir/gcc 2> /dev/null` ; do
if test x"$ac_cv_path_cc" = x ; then
if test -f "$j" ; then
ac_cv_path_cc=$j
break
fi
fi
done
done
;;
esac
fi
fi
fi
# Also set EXEEXT_FOR_BUILD.
if test "x$cross_compiling" = "xno"; then
EXEEXT_FOR_BUILD='$(EXEEXT)'
OBJEXT_FOR_BUILD='$(OBJEXT)'
else
OBJEXT_FOR_BUILD='.no'
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5
printf %s "checking for build system executable suffix... " >&6; }
if test ${bfd_cv_build_exeext+y}
then :
printf %s "(cached) " >&6
else case e in #(
e) rm -f conftest*
echo 'int main () { return 0; }' > conftest.c
bfd_cv_build_exeext=
${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
for file in conftest.*; do
case $file in
*.c | *.o | *.obj | *.ilk | *.pdb) ;;
*) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
esac
done
rm -f conftest*
test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no ;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5
printf "%s\n" "$bfd_cv_build_exeext" >&6; }
EXEEXT_FOR_BUILD=""
test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
fi
|
| ︙ | ︙ | |||
11278 11279 11280 11281 11282 11283 11284 |
if test ${ac_cv_path_macher+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 11174 11175 11176 11177 11178 11179 11180 11181 11182 11183 11184 11185 11186 11187 11188 11189 11190 11191 11192 11193 11194 11195 11196 11197 11198 11199 11200 11201 11202 11203 11204 11205 11206 11207 11208 11209 11210 11211 11212 11213 11214 11215 11216 11217 11218 11219 11220 11221 11222 11223 11224 11225 11226 11227 11228 11229 11230 11231 11232 11233 11234 11235 11236 11237 11238 11239 11240 11241 11242 11243 11244 11245 11246 11247 11248 |
if test ${ac_cv_path_macher+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/macher 2> /dev/null` \
`ls -r $dir/macher 2> /dev/null` ; do
if test x"$ac_cv_path_macher" = x ; then
if test -f "$j" ; then
ac_cv_path_macher=$j
break
fi
fi
done
done
;;
esac
fi
if test -f "$ac_cv_path_macher" ; then
MACHER_PROG="$ac_cv_path_macher"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MACHER_PROG" >&5
printf "%s\n" "$MACHER_PROG" >&6; }
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found macher in environment" >&5
printf "%s\n" "Found macher in environment" >&6; }
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for zip" >&5
printf %s "checking for zip... " >&6; }
if test ${ac_cv_path_zip+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
;;
esac
fi
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
printf "%s\n" "$ZIP_PROG" >&6; }
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
printf "%s\n" "Found INFO Zip in environment" >&6; }
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH. Building minizip" >&5
printf "%s\n" "No zip found on PATH. Building minizip" >&6; }
fi
|
| ︙ | ︙ | |||
11396 11397 11398 11399 11400 11401 11402 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
| | > > | | | 11292 11293 11294 11295 11296 11297 11298 11299 11300 11301 11302 11303 11304 11305 11306 11307 11308 11309 11310 11311 11312 11313 11314 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl:/Library/Tcl:~/Library/Frameworks:/Library/Frameworks"
# Allow tclsh to find Tk when multiple versions are installed. See Tk [1562e10c58].
TCL_PACKAGE_PATH="$TCL_PACKAGE_PATH:/Library/Frameworks/Tk.framework/Versions"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="${libdir}:${prefix}/lib"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="${prefix}/lib"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
12617 12618 12619 12620 12621 12622 12623 |
printf "%s\n" "$as_me: executing $ac_file commands" >&6;}
;;
esac
case $ac_file$ac_mode in
"Tcl.framework":C) n=Tcl &&
| | | | | | | 12515 12516 12517 12518 12519 12520 12521 12522 12523 12524 12525 12526 12527 12528 12529 12530 12531 12532 12533 |
printf "%s\n" "$as_me: executing $ac_file commands" >&6;}
;;
esac
case $ac_file$ac_mode in
"Tcl.framework":C) n=Tcl &&
f=$n.framework && v=Versions/$VERSION &&
rm -rf $f && mkdir -p $f/$v/Resources &&
ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v &&
ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist &&
unset n f v
;;
esac
done # for ac_tag
as_fn_exit 0
|
| ︙ | ︙ |
Changes to unix/configure.ac.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
/* override */ #undef PACKAGE_STRING
#endif /* _TCLCONFIG */])
])
TCL_VERSION=9.0
TCL_MAJOR_VERSION=9
TCL_MINOR_VERSION=0
| | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
/* override */ #undef PACKAGE_STRING
#endif /* _TCLCONFIG */])
])
TCL_VERSION=9.0
TCL_MAJOR_VERSION=9
TCL_MINOR_VERSION=0
TCL_PATCH_LEVEL=".2"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}
#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 168 |
AC_SEARCH_LIBS([deflateSetHeader],[z],[],[
zlib_ok=no
])])
AS_IF([test $zlib_ok = no], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}])
AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}])
])
| > < | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
AC_SEARCH_LIBS([deflateSetHeader],[z],[],[
zlib_ok=no
])])
AS_IF([test $zlib_ok = no], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}])
AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}])
AC_DEFINE(TCL_WITH_INTERNAL_ZLIB, 1, [Tcl with internal zlib])
])
#------------------------------------------------------------------------
# Add stuff for libtommath
libtommath_ok=yes
AC_ARG_WITH(system-libtommath,
AS_HELP_STRING([--with-system-libtommath],
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
if test "$ac_cv_cygwin" != "yes"; then
AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize, struct stat.st_rdev])
fi
AC_CHECK_TYPES([blkcnt_t])
AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])])
| < < < < < < < < < < | | 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 |
if test "$ac_cv_cygwin" != "yes"; then
AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize, struct stat.st_rdev])
fi
AC_CHECK_TYPES([blkcnt_t])
AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])])
#--------------------------------------------------------------------
# Check for various typedefs and provide substitutes if
# they don't exist.
#--------------------------------------------------------------------
AC_TYPE_MODE_T
AC_TYPE_PID_T
AC_TYPE_SIZE_T
AC_TYPE_UID_T
AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <sys/socket.h>
]], [[
socklen_t foo;
]])],[tcl_cv_type_socklen_t=yes],[tcl_cv_type_socklen_t=no])])
if test $tcl_cv_type_socklen_t = no; then
AC_DEFINE(socklen_t, int, [Define as int if socklen_t is not available])
fi
AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[
#include <stdint.h>
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
AC_CHECK_HEADERS(libkern/OSAtomic.h)
AC_CHECK_FUNCS(OSSpinLockLock)
fi
AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1,
[Can this platform load code from memory?])
AC_DEFINE(TCL_WIDE_CLICKS, 1,
[Does this platform have wide high-resolution clicks?])
| < < | | < < < < < < < | | | | | | | | | | | < < < < < < < | | | | | | | < | 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 |
AC_CHECK_HEADERS(libkern/OSAtomic.h)
AC_CHECK_FUNCS(OSSpinLockLock)
fi
AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1,
[Can this platform load code from memory?])
AC_DEFINE(TCL_WIDE_CLICKS, 1,
[Does this platform have wide high-resolution clicks?])
AC_CACHE_CHECK([if weak import is available], tcl_cv_cc_weak_import, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[
int rand(void) __attribute__((weak_import));
]], [[rand();]])],
[tcl_cv_cc_weak_import=yes],[tcl_cv_cc_weak_import=no])
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_weak_import = yes; then
AC_DEFINE(HAVE_WEAK_IMPORT, 1, [Is weak import available?])
fi
AC_CACHE_CHECK([if Darwin SUSv3 extensions are available],
tcl_cv_cc_darwin_c_source, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#define _DARWIN_C_SOURCE 1
#include <sys/cdefs.h>
]], [[]])],[tcl_cv_cc_darwin_c_source=yes],[tcl_cv_cc_darwin_c_source=no])
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_darwin_c_source = yes; then
AC_DEFINE(_DARWIN_C_SOURCE, 1,
[Are Darwin SUSv3 extensions available?])
fi
# Build .bundle dltest binaries in addition to .dylib
DLTEST_LD='${CC} -bundle -Wl,-w ${CFLAGS} ${LDFLAGS}'
DLTEST_SUFFIX=".bundle"
else
DLTEST_LD='${SHLIB_LD}'
DLTEST_SUFFIX=""
|
| ︙ | ︙ | |||
723 724 725 726 727 728 729 |
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
AC_CACHE_CHECK([whether the cpuid instruction is usable], tcl_cv_cpuid, [
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[
int index,regsPtr[4];
__asm__ __volatile__("mov %%ebx, %%edi \n\t"
| | | | | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
AC_CACHE_CHECK([whether the cpuid instruction is usable], tcl_cv_cpuid, [
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[
int index,regsPtr[4];
__asm__ __volatile__("mov %%ebx, %%edi \n\t"
"cpuid \n\t"
"mov %%ebx, %%esi \n\t"
"mov %%edi, %%ebx \n\t"
: "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
: "a"(index) : "edi");
]])],[tcl_cv_cpuid=yes],[tcl_cv_cpuid=no])])
if test $tcl_cv_cpuid = yes; then
AC_DEFINE(HAVE_CPUID, 1, [Is the cpuid instruction usable?])
fi
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
|
| ︙ | ︙ | |||
773 774 775 776 777 778 779 |
fi
if test "$FRAMEWORK_BUILD" = "1" ; then
AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?])
# Construct a fake local framework structure to make linking with
# '-framework Tcl' and running of tcltest work
AC_CONFIG_COMMANDS([Tcl.framework], [n=Tcl &&
| | | | | | | | | | | 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 |
fi
if test "$FRAMEWORK_BUILD" = "1" ; then
AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?])
# Construct a fake local framework structure to make linking with
# '-framework Tcl' and running of tcltest work
AC_CONFIG_COMMANDS([Tcl.framework], [n=Tcl &&
f=$n.framework && v=Versions/$VERSION &&
rm -rf $f && mkdir -p $f/$v/Resources &&
ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v &&
ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist &&
unset n f v
], VERSION=${TCL_VERSION})
LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH"
# default install directory for bundled packages
if test "${libdir}" = '${exec_prefix}/lib' -o "`basename ${libdir}`" = 'Frameworks'; then
PACKAGE_DIR="/Library/Tcl"
else
PACKAGE_DIR="$libdir"
fi
if test "${libdir}" = '${exec_prefix}/lib'; then
# override libdir default
libdir="/Library/Frameworks"
fi
TCL_LIB_FILE="Tcl"
TCL_LIB_FLAG="-framework Tcl"
TCL_BUILD_LIB_SPEC="-F`pwd | sed -e 's/ /\\\\ /g'` -framework Tcl"
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 |
EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
# libdir must be a fully qualified path and not ${exec_prefix}/lib
eval libdir="$libdir"
# default install directory for bundled packages
PACKAGE_DIR="$libdir"
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
| | | | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
# libdir must be a fully qualified path and not ${exec_prefix}/lib
eval libdir="$libdir"
# default install directory for bundled packages
PACKAGE_DIR="$libdir"
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_LIB_FLAG="-ltcl${TCL_VERSION}"
else
TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`"
fi
TCL_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_LIB_FLAG}"
TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
fi
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
|
| ︙ | ︙ | |||
885 886 887 888 889 890 891 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
| | > > | | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl:/Library/Tcl:~/Library/Frameworks:/Library/Frameworks"
# Allow tclsh to find Tk when multiple versions are installed. See Tk [1562e10c58].
TCL_PACKAGE_PATH="$TCL_PACKAGE_PATH:/Library/Frameworks/Tk.framework/Versions"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="${libdir}:${prefix}/lib"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="${prefix}/lib"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to unix/dltest/embtest.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
printf("Tcl_FindExecutable gives version %s\n", version);
}
if (tclStubsPtr == NULL) {
printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n");
exitcode = 1;
}
if (!exitcode) {
| | | 30 31 32 33 34 35 36 37 38 39 40 |
printf("Tcl_FindExecutable gives version %s\n", version);
}
if (tclStubsPtr == NULL) {
printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n");
exitcode = 1;
}
if (!exitcode) {
printf("All OK!\n");
}
return exitcode;
}
|
Changes to unix/dltest/pkgb.c.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
char buf[TCL_INTEGER_SPACE];
snprintf(buf, sizeof(buf), "%d", Tcl_GetErrorLine(interp));
| | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
char buf[TCL_INTEGER_SPACE];
snprintf(buf, sizeof(buf), "%d", Tcl_GetErrorLine(interp));
Tcl_AppendResult(interp, " in line: ", buf, (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to unix/dltest/pkgooa.c.
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
* to keep working in all future Tcl 8.x releases.
*/
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (tclStubsPtr == NULL) {
Tcl_AppendResult(interp, "Tcl stubs are not initialized, "
| | | | | 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 |
* to keep working in all future Tcl 8.x releases.
*/
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (tclStubsPtr == NULL) {
Tcl_AppendResult(interp, "Tcl stubs are not initialized, "
"did you compile using -DUSE_TCL_STUBS? ", (char *)NULL);
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (tclOOStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO stubs are not initialized", (char *)NULL);
return TCL_ERROR;
}
if (tclOOIntStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO internal stubs are not initialized", (char *)NULL);
return TCL_ERROR;
}
/* Test case for Bug [f51efe99a7].
*
* Let tclOOStubsPtr point to an alternate stub table
* (with only a single function, that's enough for
|
| ︙ | ︙ |
Changes to unix/dltest/pkgua.c.
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
static void
PkguaDeleteTokens(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
Tcl_HashEntry *entryPtr =
| | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
static void
PkguaDeleteTokens(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
Tcl_HashEntry *entryPtr =
Tcl_FindHashEntry(&tsdPtr->interpTokenMap, interp);
if (entryPtr) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
Tcl_DeleteHashEntry(entryPtr);
}
}
|
| ︙ | ︙ |
Changes to unix/installManPage.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
Sym=""
Loc=""
Gz=""
Suffix=""
while true; do
case $1 in
| | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
Sym=""
Loc=""
Gz=""
Suffix=""
while true; do
case $1 in
-s | --symlinks ) Sym="-s " ;;
-z | --compress ) Gzip=$2; shift ;;
-e | --extension ) Gz=$2; shift ;;
-x | --suffix ) Suffix=$2; shift ;;
-*) cat <<EOF
Unknown option "$1". Supported options:
-s Use symbolic links for manpages with multiple names.
-z PROG Use PROG to compress manual pages.
-e EXT Defines the extension added by -z PROG when compressing.
|
| ︙ | ︙ |
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
# TCL_LIB_FILE
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
| | | | | | | 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 |
# TCL_LIB_FILE
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TCL_BIN_DIR}/tclConfig.sh"
else
AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh])
fi
# If the TCL_BIN_DIR is the build directory (not the install directory),
# then set the common variable name to the value of the build variables.
# For example, the variable TCL_LIB_SPEC will be set to the value
# of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC
# instead of TCL_BUILD_LIB_SPEC since it will work with both an
# installed and uninstalled version of Tcl.
if test -f "${TCL_BIN_DIR}/Makefile" ; then
TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}"
TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}"
TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}"
elif test "`uname -s`" = "Darwin"; then
# If Tcl was built as a framework, attempt to use the libraries
# from the framework at the given location so that linking works
# against Tcl.framework installed in an arbitrary location.
case ${TCL_DEFS} in
*TCL_FRAMEWORK*)
if test -f "${TCL_BIN_DIR}/${TCL_LIB_FILE}"; then
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
# TK_BIN_DIR
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TKCONFIG], [
AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh])
if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
| | | | | | | 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 |
# TK_BIN_DIR
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TKCONFIG], [
AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh])
if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TK_BIN_DIR}/tkConfig.sh"
else
AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh])
fi
# If the TK_BIN_DIR is the build directory (not the install directory),
# then set the common variable name to the value of the build variables.
# For example, the variable TK_LIB_SPEC will be set to the value
# of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC
# instead of TK_BUILD_LIB_SPEC since it will work with both an
# installed and uninstalled version of Tcl.
if test -f "${TK_BIN_DIR}/Makefile" ; then
TK_LIB_SPEC="${TK_BUILD_LIB_SPEC}"
TK_STUB_LIB_SPEC="${TK_BUILD_STUB_LIB_SPEC}"
TK_STUB_LIB_PATH="${TK_BUILD_STUB_LIB_PATH}"
elif test "`uname -s`" = "Darwin"; then
# If Tk was built as a framework, attempt to use the libraries
# from the framework at the given location so that linking works
# against Tk.framework installed in an arbitrary location.
case ${TK_DEFS} in
*TK_FRAMEWORK*)
if test -f "${TK_BIN_DIR}/${TK_LIB_FILE}"; then
|
| ︙ | ︙ | |||
986 987 988 989 990 991 992 |
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r|*_r\ *)
# ok ...
;;
*)
# Make sure only first arg gets _r
| | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r|*_r\ *)
# ok ...
;;
*)
# Make sure only first arg gets _r
CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'`
;;
esac
AC_MSG_RESULT([Using $CC for compiling with threads])
])
LIBS="$LIBS -lc"
SHLIB_CFLAGS=""
SHLIB_SUFFIX=".so"
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 |
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
# Check to enable 64-bit flags for compiler/linker
AS_IF([test "$do64bit" = yes], [
| | | | | | | | | < | | | | | | 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 |
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
# Check to enable 64-bit flags for compiler/linker
AS_IF([test "$do64bit" = yes], [
AS_IF([test "$GCC" = yes], [
AC_MSG_WARN([64bit mode not supported by gcc])
], [
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
CFLAGS="$CFLAGS -64"
LDFLAGS_ARCH="-64"
])
])
;;
Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*)
SHLIB_CFLAGS="-fPIC -fno-common"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE="-O2"
# egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
# when you inline the string and math operations. Turn this off to
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
case $system in
DragonFly-*|FreeBSD-*)
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
;;
esac
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"])
AS_IF([test $do64bit = yes], [
AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [
|
| ︙ | ︙ | |||
1421 1422 1423 1424 1425 1426 1427 |
], [
# Check for combined 32-bit and 64-bit fat build
AS_IF([echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64|arm64) ' \
&& echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '], [
fat_32_64=yes])
])
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
| < < < < < < < < < | 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
], [
# Check for combined 32-bit and 64-bit fat build
AS_IF([echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64|arm64) ' \
&& echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '], [
fat_32_64=yes])
])
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -headerpad_max_install_names"
AC_CACHE_CHECK([if ld accepts -search_paths_first flag],
tcl_cv_ld_search_paths_first, [
hold_ldflags=$LDFLAGS
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 | AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <CoreFoundation/CoreFoundation.h>]], [[CFBundleRef b = CFBundleGetMainBundle();]])], [tcl_cv_lib_corefoundation=yes], [tcl_cv_lib_corefoundation=no]) AS_IF([test "$fat_32_64" = yes], [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' | | | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 | AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <CoreFoundation/CoreFoundation.h>]], [[CFBundleRef b = CFBundleGetMainBundle();]])], [tcl_cv_lib_corefoundation=yes], [tcl_cv_lib_corefoundation=no]) AS_IF([test "$fat_32_64" = yes], [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) LIBS=$hold_libs]) AS_IF([test $tcl_cv_lib_corefoundation = yes], [ LIBS="$LIBS -framework CoreFoundation" AC_DEFINE(HAVE_COREFOUNDATION, 1, [Do we have access to Darwin CoreFoundation.framework?]) ], [tcl_corefoundation=no]) AS_IF([test "$fat_32_64" = yes -a $tcl_corefoundation = yes],[ |
| ︙ | ︙ | |||
1505 1506 1507 1508 1509 1510 1511 | [tcl_cv_lib_corefoundation_64=no]) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) AS_IF([test $tcl_cv_lib_corefoundation_64 = no], [ AC_DEFINE(NO_COREFOUNDATION_64, 1, [Is Darwin CoreFoundation unavailable for 64-bit?]) | | | | | 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 |
[tcl_cv_lib_corefoundation_64=no])
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
done])
AS_IF([test $tcl_cv_lib_corefoundation_64 = no], [
AC_DEFINE(NO_COREFOUNDATION_64, 1,
[Is Darwin CoreFoundation unavailable for 64-bit?])
LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings"
])
])
])
;;
OS/390-*)
SHLIB_LD_LIBS=""
CFLAGS_OPTIMIZE="" # Optimizer is buggy
AC_DEFINE(_OE_SOCKETS, 1, # needed in sys/socket.h
[Should OS/390 do the right thing with sockets?])
;;
OSF1-V*)
# Digital OSF/1
SHLIB_CFLAGS=""
AS_IF([test "$SHARED_BUILD" = 1], [
SHLIB_LD='${CC} -shared'
], [
SHLIB_LD='${CC} -non_shared'
])
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
|
| ︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 | DL_LIBS="-ldl" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. AC_CACHE_CHECK([for ld accepts -Bexport flag], tcl_cv_ld_Bexport, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[int i;]])],[tcl_cv_ld_Bexport=yes],[tcl_cv_ld_Bexport=no]) | | | 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 |
DL_LIBS="-ldl"
# Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
# that don't grok the -Bexport option. Test that it does.
AC_CACHE_CHECK([for ld accepts -Bexport flag], tcl_cv_ld_Bexport, [
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-Bexport"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[int i;]])],[tcl_cv_ld_Bexport=yes],[tcl_cv_ld_Bexport=no])
LDFLAGS=$hold_ldflags])
AS_IF([test $tcl_cv_ld_Bexport = yes], [
LDFLAGS="$LDFLAGS -Wl,-Bexport"
])
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
esac
|
| ︙ | ︙ | |||
1795 1796 1797 1798 1799 1800 1801 |
AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [
SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'])
AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [
UNSHARED_LIB_SUFFIX='${VERSION}.a'])
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [
| | | | | | | | | | | | | | | | | | | | 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 |
AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [
SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'])
AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [
UNSHARED_LIB_SUFFIX='${VERSION}.a'])
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
], [
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
])
], [
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
AS_IF([test "$RANLIB" = ""], [
MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}'
], [
MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@'
])
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
])
# Stub lib does not depend on shared/static configuration
AS_IF([test "$RANLIB" = ""], [
MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}'
], [
MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@'
])
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"'
# Define TCL_LIBS now that we know what DL_LIBS is.
# The trick here is that we don't want to change the value of TCL_LIBS if
# it is already set when tclConfig.sh had been loaded by Tk.
AS_IF([test "x${TCL_LIBS}" = x], [
TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"])
AC_SUBST(TCL_LIBS)
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
AC_CACHE_CHECK(for cast to union support,
|
| ︙ | ︙ | |||
1928 1929 1930 1931 1932 1933 1934 | # # Arguments: # none # # Results: # # Defines some of the following vars: | < < < < < < < < | 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 |
#
# Arguments:
# none
#
# Results:
#
# Defines some of the following vars:
# NO_SYS_WAIT_H
# NO_DLFCN_H
# HAVE_SYS_PARAM_H
# HAVE_STRING_H ?
#
#--------------------------------------------------------------------
AC_DEFUN([SC_MISSING_POSIX_HEADERS], [
AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0)
AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0)
AC_CHECK_HEADER(sys/wait.h, , [AC_DEFINE(NO_SYS_WAIT_H, 1, [Do we have <sys/wait.h>?])])
AC_CHECK_HEADER(dlfcn.h, , [AC_DEFINE(NO_DLFCN_H, 1, [Do we have <dlfcn.h>?])])
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
AC_CHECK_HEADERS([sys/param.h])
])
|
| ︙ | ︙ | |||
2101 2102 2103 2104 2105 2106 2107 |
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TIME_HANDLER], [
AC_CHECK_HEADERS(sys/time.h)
AC_CHECK_HEADERS_ONCE([sys/time.h])
| | | 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 |
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TIME_HANDLER], [
AC_CHECK_HEADERS(sys/time.h)
AC_CHECK_HEADERS_ONCE([sys/time.h])
AC_CHECK_FUNCS(gmtime_r localtime_r)
AC_CACHE_CHECK([tm_tzadj in struct tm], tcl_cv_member_tm_tzadj, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <time.h>]], [[struct tm tm; (void)tm.tm_tzadj;]])],
[tcl_cv_member_tm_tzadj=yes],
[tcl_cv_member_tm_tzadj=no])])
if test $tcl_cv_member_tm_tzadj = yes ; then
AC_DEFINE(HAVE_TM_TZADJ, 1, [Should we use the tm_tzadj field of struct tm?])
|
| ︙ | ︙ | |||
2349 2350 2351 2352 2353 2354 2355 |
AC_DEFUN([SC_TCL_64BIT_FLAGS], [
AC_MSG_CHECKING([if 'long' and 'long long' have the same size (64-bit)?])
AC_CACHE_VAL(tcl_cv_type_64bit,[
tcl_cv_type_64bit=none
# See if we could use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
| | | | | 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 |
AC_DEFUN([SC_TCL_64BIT_FLAGS], [
AC_MSG_CHECKING([if 'long' and 'long long' have the same size (64-bit)?])
AC_CACHE_VAL(tcl_cv_type_64bit,[
tcl_cv_type_64bit=none
# See if we could use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[switch (0) {
case 1: case (sizeof(long long)==sizeof(long)): ;
}]])],[tcl_cv_type_64bit="long long"],[])])
if test "${tcl_cv_type_64bit}" = none ; then
AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Do 'long' and 'long long' have the same size (64-bit)?])
AC_MSG_RESULT([yes])
else
AC_MSG_RESULT([no])
# Now check for auxiliary declarations
AC_CACHE_CHECK([for 64-bit time_t], tcl_cv_time_t_64,[
|
| ︙ | ︙ | |||
2386 2387 2388 2389 2390 2391 2392 |
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in <sys/types.h>?])
fi
AC_CACHE_CHECK([for DIR64], tcl_cv_DIR64,[
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
#include <dirent.h>]], [[struct dirent64 *p; DIR64 d = opendir64(".");
| | | | | 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 |
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in <sys/types.h>?])
fi
AC_CACHE_CHECK([for DIR64], tcl_cv_DIR64,[
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
#include <dirent.h>]], [[struct dirent64 *p; DIR64 d = opendir64(".");
p = readdir64(d); rewinddir64(d); closedir64(d);]])],
[tcl_cv_DIR64=yes], [tcl_cv_DIR64=no])])
if test "x${tcl_cv_DIR64}" = "xyes" ; then
AC_DEFINE(HAVE_DIR64, 1, [Is 'DIR64' in <sys/types.h>?])
fi
AC_CHECK_FUNCS(open64 lseek64)
AC_MSG_CHECKING([for off64_t])
AC_CACHE_VAL(tcl_cv_type_off64_t,[
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>]], [[off64_t offset;
]])],
[tcl_cv_type_off64_t=yes], [tcl_cv_type_off64_t=no])])
dnl Define HAVE_TYPE_OFF64_T only when the off64_t type and the
dnl functions lseek64 and open64 are defined.
if test "x${tcl_cv_type_off64_t}" = "xyes" && \
test "x${ac_cv_func_lseek64}" = "xyes" && \
test "x${ac_cv_func_open64}" = "xyes" ; then
AC_DEFINE(HAVE_TYPE_OFF64_T, 1, [Is off64_t in <sys/types.h>?])
AC_MSG_RESULT([yes])
else
AC_MSG_RESULT([no])
fi
fi
])
|
| ︙ | ︙ | |||
2904 2905 2906 2907 2908 2909 2910 | #include <sys/types.h> #include <sys/socket.h> #include <netinet/in.h> #include <netdb.h> ]]) if test "x$NEED_FAKE_RFC2553" = "x1"; then AC_DEFINE([NEED_FAKE_RFC2553], 1, | | | 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 | #include <sys/types.h> #include <sys/socket.h> #include <netinet/in.h> #include <netdb.h> ]]) if test "x$NEED_FAKE_RFC2553" = "x1"; then AC_DEFINE([NEED_FAKE_RFC2553], 1, [Use compat implementation of getaddrinfo() and friends]) AC_LIBOBJ([fake-rfc2553]) AC_CHECK_FUNC(strlcpy) fi ]) #------------------------------------------------------------------------ # SC_CC_FOR_BUILD |
| ︙ | ︙ | |||
2927 2928 2929 2930 2931 2932 2933 |
# EXEEXT_FOR_BUILD
#------------------------------------------------------------------------
dnl Get a default for CC_FOR_BUILD to put into Makefile.
AC_DEFUN([AX_CC_FOR_BUILD],[# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 |
# EXEEXT_FOR_BUILD
#------------------------------------------------------------------------
dnl Get a default for CC_FOR_BUILD to put into Makefile.
AC_DEFUN([AX_CC_FOR_BUILD],[# Put a plausible default for CC_FOR_BUILD in Makefile.
if test -z "$CC_FOR_BUILD"; then
if test "x$cross_compiling" = "xno"; then
CC_FOR_BUILD='$(CC)'
else
AC_MSG_CHECKING([for gcc])
AC_CACHE_VAL(ac_cv_path_cc, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/gcc 2> /dev/null` \
`ls -r $dir/gcc 2> /dev/null` ; do
if test x"$ac_cv_path_cc" = x ; then
if test -f "$j" ; then
ac_cv_path_cc=$j
break
fi
fi
done
done
])
fi
fi
AC_SUBST(CC_FOR_BUILD)
# Also set EXEEXT_FOR_BUILD.
if test "x$cross_compiling" = "xno"; then
EXEEXT_FOR_BUILD='$(EXEEXT)'
OBJEXT_FOR_BUILD='$(OBJEXT)'
else
OBJEXT_FOR_BUILD='.no'
AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext,
[rm -f conftest*
echo 'int main () { return 0; }' > conftest.c
bfd_cv_build_exeext=
${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
for file in conftest.*; do
case $file in
*.c | *.o | *.obj | *.ilk | *.pdb) ;;
*) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
esac
done
rm -f conftest*
test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no])
EXEEXT_FOR_BUILD=""
test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
fi
AC_SUBST(EXEEXT_FOR_BUILD)])dnl
AC_SUBST(OBJEXT_FOR_BUILD)])dnl
])
|
| ︙ | ︙ | |||
3001 3002 3003 3004 3005 3006 3007 |
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
AC_MSG_CHECKING([for macher])
AC_CACHE_VAL(ac_cv_path_macher, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 |
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
AC_MSG_CHECKING([for macher])
AC_CACHE_VAL(ac_cv_path_macher, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/macher 2> /dev/null` \
`ls -r $dir/macher 2> /dev/null` ; do
if test x"$ac_cv_path_macher" = x ; then
if test -f "$j" ; then
ac_cv_path_macher=$j
break
fi
fi
done
done
])
if test -f "$ac_cv_path_macher" ; then
MACHER_PROG="$ac_cv_path_macher"
AC_MSG_RESULT([$MACHER_PROG])
AC_MSG_RESULT([Found macher in environment])
fi
AC_MSG_CHECKING([for zip])
AC_CACHE_VAL(ac_cv_path_zip, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
])
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
AC_MSG_RESULT([$ZIP_PROG])
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
AC_MSG_RESULT([Found INFO Zip in environment])
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
AC_MSG_RESULT([No zip found on PATH. Building minizip])
fi
AC_SUBST(MACHER_PROG)
AC_SUBST(ZIP_PROG)
AC_SUBST(ZIP_PROG_OPTIONS)
AC_SUBST(ZIP_PROG_VFSSEARCH)
AC_SUBST(ZIP_INSTALL_OBJS)
])
# Local Variables:
# mode: autoconf
# End:
|
Changes to unix/tcl.spec.
1 2 3 4 5 6 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tcl
Summary: Tcl scripting language development environment
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tcl
Summary: Tcl scripting language development environment
Version: 9.0.2
Release: 2
License: BSD
Group: Development/Languages
Source: https://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz
URL: https://www.tcl-lang.org/
Buildroot: /var/tmp/%{name}%{version}
%description
The Tcl (Tool Command Language) provides a powerful platform for
creating integration applications that tie together diverse
applications, protocols, devices, and frameworks. When paired with
|
| ︙ | ︙ |
Changes to unix/tclAppInit.c.
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
*/
#ifdef DJGPP
#define INITFILENAME "tclshrc.tcl"
#else
#define INITFILENAME ".tclshrc"
#endif
| | | < | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
*/
#ifdef DJGPP
#define INITFILENAME "tclshrc.tcl"
#else
#define INITFILENAME ".tclshrc"
#endif
(void) Tcl_EvalEx(interp,
"set tcl_rcFileName [file tildeexpand ~/" INITFILENAME "]",
-1, TCL_EVAL_GLOBAL);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
|
| ︙ | ︙ |
Changes to unix/tclConfig.h.in.
1 2 3 4 5 6 7 8 9 |
/* ../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
| < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
/* ../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 the system has the type 'blkcnt_t'. */
#undef HAVE_BLKCNT_T
/* Defined when compiler supports casting to union type. */
#undef HAVE_CAST_TO_UNION
/* Define to 1 if you have the 'cfmakeraw' function. */
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 | /* Define to 1 if you have the 'mkstemp' function. */ #undef HAVE_MKSTEMP /* Define to 1 if you have the 'mkstemps' function. */ #undef HAVE_MKSTEMPS | < < < | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | /* Define to 1 if you have the 'mkstemp' function. */ #undef HAVE_MKSTEMP /* Define to 1 if you have the 'mkstemps' function. */ #undef HAVE_MKSTEMPS /* Do we have MT-safe gethostbyaddr() ? */ #undef HAVE_MTSAFE_GETHOSTBYADDR /* Do we have MT-safe gethostbyname() ? */ #undef HAVE_MTSAFE_GETHOSTBYNAME /* Do we have <net/errno.h>? */ |
| ︙ | ︙ | |||
303 304 305 306 307 308 309 | /* Define to 1 if you have the 'waitpid' function. */ #undef HAVE_WAITPID /* Is weak import available? */ #undef HAVE_WEAK_IMPORT | < < < | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 | /* Define to 1 if you have the 'waitpid' function. */ #undef HAVE_WAITPID /* Is weak import available? */ #undef HAVE_WEAK_IMPORT /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE /* Default libtommath precision. */ |
| ︙ | ︙ | |||
348 349 350 351 352 353 354 | /* Do we have gettimeofday()? */ #undef NO_GETTOD /* Do we have getwd() */ #undef NO_GETWD | < < < < < < | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 | /* Do we have gettimeofday()? */ #undef NO_GETTOD /* Do we have getwd() */ #undef NO_GETWD /* Do we have mknod() */ #undef NO_MKNOD /* Do we have realpath() */ #undef NO_REALPATH /* Do we have strerror() */ #undef NO_STRERROR /* Do we have <sys/wait.h>? */ #undef NO_SYS_WAIT_H /* Do we have tcdrain() */ #undef NO_TCDRAIN /* Do we have uname() */ |
| ︙ | ︙ | |||
443 444 445 446 447 448 449 450 451 452 453 454 455 456 | /* Do 'long' and 'long long' have the same size (64-bit)? */ #undef TCL_WIDE_INT_IS_LONG /* Tcl with external libtommath */ #undef TCL_WITH_EXTERNAL_TOMMATH /* Is getcwd Posix-compliant? */ #undef USEGETWD /* Are we building with DTrace support? */ #undef USE_DTRACE /* Should we use FIONBIO? */ | > > > | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | /* Do 'long' and 'long long' have the same size (64-bit)? */ #undef TCL_WIDE_INT_IS_LONG /* Tcl with external libtommath */ #undef TCL_WITH_EXTERNAL_TOMMATH /* Tcl with internal zlib */ #undef TCL_WITH_INTERNAL_ZLIB /* Is getcwd Posix-compliant? */ #undef USEGETWD /* Are we building with DTrace support? */ #undef USE_DTRACE /* Should we use FIONBIO? */ |
| ︙ | ︙ |
Changes to unix/tclEpollNotfy.c.
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
newEvent.events |= EPOLLIN;
}
if (filePtr->mask & TCL_WRITABLE) {
newEvent.events |= EPOLLOUT;
}
if (isNew) {
| | | | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
newEvent.events |= EPOLLIN;
}
if (filePtr->mask & TCL_WRITABLE) {
newEvent.events |= EPOLLOUT;
}
if (isNew) {
newPedPtr = (struct PlatformEventData *)
Tcl_Alloc(sizeof(struct PlatformEventData));
newPedPtr->filePtr = filePtr;
newPedPtr->tsdPtr = tsdPtr;
filePtr->pedPtr = newPedPtr;
}
newEvent.data.ptr = filePtr->pedPtr;
/*
* N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support
* regular files (S_IFREG). Therefore, filePtr is in these cases simply
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 | * above operations are protected by tsdPtr->notifierMutex, which is * destroyed thereafter. * * Results: * None. * * Side effects: | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | * above operations are protected by tsdPtr->notifierMutex, which is * destroyed thereafter. * * Results: * None. * * Side effects: * While tsdPtr->notifierMutex is held: * - The per-thread eventfd(2) is closed, if non-zero, and set to -1. * - The per-thread epoll(7) fd is closed, if non-zero, and set to 0. * - The per-thread epoll_event structs are freed, if any, and set to 0. * * tsdPtr->notifierMutex is destroyed. * *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
tsdPtr->triggerFilePtr = filePtr;
if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) {
Tcl_Panic("epoll_create1: %s", strerror(errno));
}
filePtr->mask = TCL_READABLE;
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1);
if (!tsdPtr->readyEvents) {
| | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
tsdPtr->triggerFilePtr = filePtr;
if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) {
Tcl_Panic("epoll_create1: %s", strerror(errno));
}
filePtr->mask = TCL_READABLE;
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1);
if (!tsdPtr->readyEvents) {
tsdPtr->maxReadyEvents = 512;
tsdPtr->readyEvents = (struct epoll_event *) Tcl_Alloc(
tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
}
LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}
/*
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
#ifdef HAVE_EVENTFD
if (filePtr->fd == tsdPtr->triggerEventFd) {
uint64_t eventFdVal;
i = read(tsdPtr->triggerEventFd, &eventFdVal, sizeof(eventFdVal));
if ((i != sizeof(eventFdVal)) && (errno != EAGAIN)) {
Tcl_Panic("%s: read from %p->triggerEventFd: %s",
| | | | 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 |
#ifdef HAVE_EVENTFD
if (filePtr->fd == tsdPtr->triggerEventFd) {
uint64_t eventFdVal;
i = read(tsdPtr->triggerEventFd, &eventFdVal, sizeof(eventFdVal));
if ((i != sizeof(eventFdVal)) && (errno != EAGAIN)) {
Tcl_Panic("%s: read from %p->triggerEventFd: %s",
"Tcl_WaitForEvent", tsdPtr, strerror(errno));
}
continue;
}
#else /* !HAVE_EVENTFD */
if (filePtr->fd == tsdPtr->triggerPipe[0]) {
char triggerPipeVal;
i = read(tsdPtr->triggerPipe[0], &triggerPipeVal,
sizeof(triggerPipeVal));
if ((i != sizeof(triggerPipeVal)) && (errno != EAGAIN)) {
Tcl_Panic("%s: read from %p->triggerPipe[0]: %s",
"Tcl_WaitForEvent", tsdPtr, strerror(errno));
}
continue;
}
#endif /* HAVE_EVENTFD */
if (!mask) {
continue;
}
|
| ︙ | ︙ |
Changes to unix/tclKqueueNotfy.c.
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
* with regular files belonging to tsdPtr.
*/
if (TclOSfstat(filePtr->fd, &fdStat) == -1) {
Tcl_Panic("fstat: %s", strerror(errno));
} else if ((fdStat.st_mode & S_IFMT) == S_IFREG
|| (fdStat.st_mode & S_IFMT) == S_IFDIR
| | < | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
* with regular files belonging to tsdPtr.
*/
if (TclOSfstat(filePtr->fd, &fdStat) == -1) {
Tcl_Panic("fstat: %s", strerror(errno));
} else if ((fdStat.st_mode & S_IFMT) == S_IFREG
|| (fdStat.st_mode & S_IFMT) == S_IFDIR
|| (fdStat.st_mode & S_IFMT) == S_IFLNK) {
switch (op) {
case EV_ADD:
if (isNew) {
LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr,
readyNode);
}
break;
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 | * operations are protected by tsdPtr->notifierMutex, which is destroyed * thereafter. * * Results: * None. * * Side effects: | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 | * operations are protected by tsdPtr->notifierMutex, which is destroyed * thereafter. * * Results: * None. * * Side effects: * While tsdPtr->notifierMutex is held: * The per-thread pipe(2) fds are closed, if non-zero, and set to -1. * The per-thread kqueue(2) fd is closed, if non-zero, and set to 0. * The per-thread kevent structs are freed, if any, and set to 0. * * tsdPtr->notifierMutex is destroyed. * *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
tsdPtr->readyEvents[numEvent].udata;
filePtr = pedPtr->filePtr;
mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
if (filePtr->fd == tsdPtr->triggerPipe[0]) {
i = read(tsdPtr->triggerPipe[0], buf, 1);
if ((i == -1) && (errno != EAGAIN)) {
Tcl_Panic("Tcl_WaitForEvent: read from %p->triggerPipe: %s",
| | | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 |
tsdPtr->readyEvents[numEvent].udata;
filePtr = pedPtr->filePtr;
mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
if (filePtr->fd == tsdPtr->triggerPipe[0]) {
i = read(tsdPtr->triggerPipe[0], buf, 1);
if ((i == -1) && (errno != EAGAIN)) {
Tcl_Panic("Tcl_WaitForEvent: read from %p->triggerPipe: %s",
tsdPtr, strerror(errno));
}
continue;
}
if (!mask) {
continue;
}
|
| ︙ | ︙ |
Changes to unix/tclLoadAix.c.
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
/*
* Scan the list of modules if we have the module already loaded.
*/
for (mp = modList; mp; mp = mp->next) {
if (strcmp(mp->name, path) == 0) {
mp->refCnt++;
| | | | 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 |
/*
* Scan the list of modules if we have the module already loaded.
*/
for (mp = modList; mp; mp = mp->next) {
if (strcmp(mp->name, path) == 0) {
mp->refCnt++;
return (void *)mp;
}
}
mp = (ModulePtr) calloc(1, sizeof(*mp));
if (mp == NULL) {
errvalid++;
strcpy(errbuf, "calloc: ");
strcat(errbuf, strerror(errno));
return NULL;
}
mp->name = malloc(strlen(path) + 1);
strcpy(mp->name, path);
/*
* load should be declared load(const char *...). Thus we cast the path to
* a normal char *. Ugly.
*/
mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL);
if (mp->entry == NULL) {
free(mp->name);
free(mp);
errvalid++;
strcpy(errbuf, "dlopen: ");
strcat(errbuf, path);
strcat(errbuf, ": ");
|
| ︙ | ︙ | |||
227 228 229 230 231 232 233 |
mp->cdtors->init();
mp->cdtors++;
}
} else {
errvalid = 0;
}
| | | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 |
mp->cdtors->init();
mp->cdtors++;
}
} else {
errvalid = 0;
}
return (void *)mp;
}
/*
* Attempt to decipher an AIX loader error message and append it to our static
* error message buffer.
*/
|
| ︙ | ︙ | |||
249 250 251 252 253 254 255 |
p++;
}
switch (atoi(s)) { /* INTL: "C", UTF safe. */
case L_ERROR_TOOMANY:
strcat(errbuf, "to many errors");
break;
case L_ERROR_NOLIB:
| | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
p++;
}
switch (atoi(s)) { /* INTL: "C", UTF safe. */
case L_ERROR_TOOMANY:
strcat(errbuf, "to many errors");
break;
case L_ERROR_NOLIB:
strcat(errbuf, "cannot load library");
strcat(errbuf, p);
break;
case L_ERROR_UNDEF:
strcat(errbuf, "cannot find symbol");
strcat(errbuf, p);
break;
case L_ERROR_RLDBAD:
strcat(errbuf, "bad RLD");
strcat(errbuf, p);
break;
case L_ERROR_FORMAT:
|
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
*/
native = (const char *)Tcl_FSGetNativePath(pathPtr);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
| | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
*/
native = (const char *)Tcl_FSGetNativePath(pathPtr);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
dlopenflags |= RTLD_GLOBAL;
} else {
dlopenflags |= RTLD_LOCAL;
}
if (flags & TCL_LOAD_LAZY) {
dlopenflags |= RTLD_LAZY;
} else {
dlopenflags |= RTLD_NOW;
}
handle = dlopen(native, dlopenflags);
if (handle == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
const char *symbol) /* Symbol to look up. */
{
const char *native; /* Name of the library to be loaded, in
* system encoding */
Tcl_DString newName, ds; /* Buffers for converting the name to
* system encoding and prepending an
* underscore*/
| | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
const char *symbol) /* Symbol to look up. */
{
const char *native; /* Name of the library to be loaded, in
* system encoding */
Tcl_DString newName, ds; /* Buffers for converting the name to
* system encoding and prepending an
* underscore*/
void *handle = loadHandle->clientData;
/* Native handle to the loaded library */
void *proc; /* Address corresponding to the resolved
* symbol */
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again with
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
if (interp) {
if (!errorStr) {
errorStr = "unknown";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s", symbol, errorStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
| | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
if (interp) {
if (!errorStr) {
errorStr = "unknown";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s", symbol, errorStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
(char *)NULL);
}
}
return proc;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to unix/tclLoadDyld.c.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | #include "tclInt.h" #ifndef MODULE_SCOPE # define MODULE_SCOPE extern #endif | < < < < < < < < < < < < < < < < < < < < < | < | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
#include "tclInt.h"
#ifndef MODULE_SCOPE
# define MODULE_SCOPE extern
#endif
/*
* Use includes for the API we're using.
*/
#include <dlfcn.h>
#if defined(TCL_LOAD_FROM_MEMORY)
#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#endif
#include <mach-o/dyld.h>
#include <mach-o/fat.h>
#include <mach-o/swap.h>
#include <mach-o/arch.h>
#include <libkern/OSByteOrder.h>
#include <mach/mach.h>
typedef struct Tcl_DyldModuleHandle {
struct Tcl_DyldModuleHandle *nextPtr;
NSModule module;
} Tcl_DyldModuleHandle;
#endif /* TCL_LOAD_FROM_MEMORY */
typedef struct {
void *dlHandle;
#if defined(TCL_LOAD_FROM_MEMORY)
const struct mach_header *dyldLibHeader;
Tcl_DyldModuleHandle *modulePtr;
#endif
} Tcl_DyldLoadHandle;
/*
* Static functions defined in this file.
*/
static void * FindSymbol(Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, const char *symbol);
static void UnloadFile(Tcl_LoadHandle handle);
/*
*----------------------------------------------------------------------
*
* TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns a handle
* to the new code.
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
* function which should be used for this
* file. */
int flags)
{
Tcl_DyldLoadHandle *dyldLoadHandle;
Tcl_LoadHandle newHandle;
void *dlHandle = NULL;
| | < < < < < < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | | < < < < < < < | 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 |
* function which should be used for this
* file. */
int flags)
{
Tcl_DyldLoadHandle *dyldLoadHandle;
Tcl_LoadHandle newHandle;
void *dlHandle = NULL;
#if defined(TCL_LOAD_FROM_MEMORY)
const struct mach_header *dyldLibHeader = NULL;
Tcl_DyldModuleHandle *modulePtr = NULL;
#endif
const char *errMsg = NULL;
int result;
Tcl_DString ds;
const char *nativePath, *nativeFileName = NULL;
int dlopenflags = 0;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = (const char *)Tcl_FSGetNativePath(pathPtr);
if (Tcl_UtfToExternalDStringEx(interp, NULL, TclGetString(pathPtr),
TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
nativeFileName = Tcl_DStringValue(&ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
dlopenflags |= RTLD_GLOBAL;
} else {
dlopenflags |= RTLD_LOCAL;
}
if (flags & TCL_LOAD_LAZY) {
dlopenflags |= RTLD_LAZY;
} else {
dlopenflags |= RTLD_NOW;
}
dlHandle = dlopen(nativePath, dlopenflags);
if (!dlHandle) {
/*
* Let the OS loader examine the binary search path for whatever string
* the user gave us which hopefully refers to a file on the binary
* path.
*/
dlHandle = dlopen(nativeFileName, dlopenflags);
if (!dlHandle) {
errMsg = dlerror();
}
}
if (dlHandle) {
dyldLoadHandle = (Tcl_DyldLoadHandle *)Tcl_Alloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = dlHandle;
#if defined(TCL_LOAD_FROM_MEMORY)
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
#endif /* TCL_LOAD_FROM_MEMORY */
newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
result = TCL_OK;
} else {
Tcl_Obj *errObj;
TclNewObj(errObj);
if (errMsg != NULL) {
Tcl_AppendToObj(errObj, errMsg, TCL_INDEX_NONE);
}
Tcl_SetObjResult(interp, errObj);
result = TCL_ERROR;
}
Tcl_DStringFree(&ds);
return result;
}
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 |
if (Tcl_UtfToExternalDStringEx(interp, NULL, symbol, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return NULL;
}
native = Tcl_DStringValue(&ds);
if (dyldLoadHandle->dlHandle) {
| < < | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
if (Tcl_UtfToExternalDStringEx(interp, NULL, symbol, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return NULL;
}
native = Tcl_DStringValue(&ds);
if (dyldLoadHandle->dlHandle) {
proc = (Tcl_LibraryInitProc *)dlsym(dyldLoadHandle->dlHandle, native);
if (!proc) {
errMsg = dlerror();
}
} else {
#if defined(TCL_LOAD_FROM_MEMORY)
NSSymbol nsSymbol = NULL;
Tcl_DString newName;
/*
* dyld adds an underscore to the beginning of symbol names.
*/
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
nsSymbol = NSLookupSymbolInModule(
dyldLoadHandle->modulePtr->module, native);
}
if (nsSymbol) {
proc = (Tcl_LibraryInitProc *)NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
| | | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
nsSymbol = NSLookupSymbolInModule(
dyldLoadHandle->modulePtr->module, native);
}
if (nsSymbol) {
proc = (Tcl_LibraryInitProc *)NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
#endif /* TCL_LOAD_FROM_MEMORY */
}
Tcl_DStringFree(&ds);
if (errMsg && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s", symbol, errMsg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
(char *)NULL);
}
return (void *)proc;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
448 449 450 451 452 453 454 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
if (dyldLoadHandle->dlHandle) {
| < < | | | 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 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
if (dyldLoadHandle->dlHandle) {
(void) dlclose(dyldLoadHandle->dlHandle);
} else {
#if defined(TCL_LOAD_FROM_MEMORY)
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
void *ptr = modulePtr;
(void) NSUnLinkModule(modulePtr->module,
NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
modulePtr = modulePtr->nextPtr;
Tcl_Free(ptr);
}
#endif /* TCL_LOAD_FROM_MEMORY */
}
Tcl_Free(dyldLoadHandle);
Tcl_Free(loadHandle);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 | * *---------------------------------------------------------------------- */ #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer( | < | < < < < < | | | | | | < | 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 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
size_t size) /* Size of desired buffer. */
{
void *buffer = NULL;
/*
* We must allocate the buffer using vm_allocate, because
* NSCreateObjectFileImageFromMemory will dispose of it using
* vm_deallocate.
*/
if (vm_allocate(mach_task_self(), (vm_address_t *) &buffer, size, 1)) {
buffer = NULL;
}
return buffer;
}
#endif /* TCL_LOAD_FROM_MEMORY */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 | * *---------------------------------------------------------------------- */ #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE int TclpLoadMemory( | < | | > < | 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 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE int
TclpLoadMemory(
void *buffer, /* Buffer containing the desired code
* (allocated with TclpLoadMemoryGetBuffer). */
size_t size, /* Allocation size of buffer. */
Tcl_Size codeSize, /* Size of code data read into buffer or -1 if
* an error occurred and the buffer should
* just be freed. */
const char *path,
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
Tcl_DyldLoadHandle *dyldLoadHandle;
NSObjectFileImage dyldObjFileImage = NULL;
Tcl_DyldModuleHandle *modulePtr;
NSModule module;
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
/*
* Try to create an object file image that we can load from.
*/
if (codeSize >= 0) {
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 | #else const struct mach_header_64 *mh = NULL; # define mh_size sizeof(struct mach_header_64) # define mh_magic MH_MAGIC_64 # define arch_abi CPU_ARCH_ABI64 #endif /* __LP64__ */ | | | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
#else
const struct mach_header_64 *mh = NULL;
# define mh_size sizeof(struct mach_header_64)
# define mh_magic MH_MAGIC_64
# define arch_abi CPU_ARCH_ABI64
#endif /* __LP64__ */
if ((size_t)codeSize >= sizeof(struct fat_header)
&& fh->magic == OSSwapHostToBigInt32(FAT_MAGIC)) {
uint32_t fh_nfat_arch = OSSwapBigToHostInt32(fh->nfat_arch);
/*
* Fat binary, try to find mach_header for our architecture
*/
if ((size_t)codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
void *fatarchs = (char *)buffer + sizeof(struct fat_header);
const NXArchInfo *arch = NXGetLocalArchInfo();
struct fat_arch *fa;
if (fh->magic != FAT_MAGIC) {
swap_fat_arch((struct fat_arch *)fatarchs, fh_nfat_arch, arch->byteorder);
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
mh->filetype == MH_BUNDLE)) {
err = NSObjectFileImageInappropriateFile;
}
if (err == NSObjectFileImageSuccess) {
err = NSCreateObjectFileImageFromMemory(buffer, codeSize,
&dyldObjFileImage);
| < < < < < | < < < < < > | > > | > | < | 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 |
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
mh->filetype == MH_BUNDLE)) {
err = NSObjectFileImageInappropriateFile;
}
if (err == NSObjectFileImageSuccess) {
err = NSCreateObjectFileImageFromMemory(buffer, codeSize,
&dyldObjFileImage);
}
}
/*
* If it went wrong (or we were asked to just deallocate), get rid of the
* memory block.
*/
if (dyldObjFileImage == NULL) {
vm_deallocate(mach_task_self(), (vm_address_t) buffer, size);
return TCL_ERROR;
}
/*
* Extract the module we want from the image of the object file.
*/
if (!(flags & 1)) {
nsflags |= NSLINKMODULE_OPTION_PRIVATE;
}
if (!(flags & 2)) {
nsflags |= NSLINKMODULE_OPTION_BINDNOW;
}
module = NSLinkModule(dyldObjFileImage, (path ? path : "[Memory Based Bundle]"), nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (!module) {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *errMsg;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <mach-o/rld.h> #include <streams/streams.h> | < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <mach-o/rld.h> #include <streams/streams.h> /* * Static procedures defined within this file. */ static void * FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void UnloadFile(Tcl_LoadHandle loadHandle); |
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
sym[1] = 0;
strcat(sym, symbol);
rld_lookup(NULL, sym, (unsigned long *) &proc);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
| | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
sym[1] = 0;
strcat(sym, symbol);
rld_lookup(NULL, sym, (unsigned long *) &proc);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, (char *)NULL);
}
return proc;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to unix/tclLoadOSF.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <sys/types.h> #include <loader.h> | < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <sys/types.h> #include <loader.h> /* * Static procedures defined within this file. */ static void * FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void UnloadFile(Tcl_LoadHandle loadHandle); |
| ︙ | ︙ | |||
125 126 127 128 129 130 131 |
* impossible to get a package name given a module.
*
* I build loadable modules with a makefile rule like
* ld ... -export $@: -o $@ $(OBJS)
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
| | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
* impossible to get a package name given a module.
*
* I build loadable modules with a makefile rule like
* ld ... -export $@: -o $@ $(OBJS)
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = pkg;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 |
const char *symbol)
{
void *proc = ldr_lookup_package((char *) loadHandle, symbol);
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
| | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
const char *symbol)
{
void *proc = ldr_lookup_package((char *) loadHandle, symbol);
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, (char *)NULL);
}
return proc;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to unix/tclLoadShl.c.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
const char *native;
char *fileName = TclGetString(pathPtr);
/*
* The flags below used to be BIND_IMMEDIATE; they were changed at the
* suggestion of Wolfgang Kechel (wolfgang@prs.de): "This enables
* verbosity for missing symbols when loading a shared lib and allows to
| | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
const char *native;
char *fileName = TclGetString(pathPtr);
/*
* The flags below used to be BIND_IMMEDIATE; they were changed at the
* suggestion of Wolfgang Kechel (wolfgang@prs.de): "This enables
* verbosity for missing symbols when loading a shared lib and allows to
* load libtk9.0.sl into tclsh9.0 without problems. In general, this
* delays resolving symbols until they are actually needed. Shared libs
* do no longer need all libraries linked in when they are build."
*/
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
/*
* Some versions of the HP system software still use "_" at the beginning
* of exported symbols while others don't; try both forms of each name.
*/
if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
| | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
/*
* Some versions of the HP system software still use "_" at the beginning
* of exported symbols while others don't; try both forms of each name.
*/
if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
(void *)&proc) != 0) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
Tcl_DStringAppend(&newName, symbol, TCL_INDEX_NONE);
if (shl_findsym(&handle, Tcl_DStringValue(&newName),
(short) TYPE_PROCEDURE, (void *)&proc) != 0) {
proc = NULL;
}
Tcl_DStringFree(&newName);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s",
|
| ︙ | ︙ |
Changes to unix/tclSelectNotfy.c.
| ︙ | ︙ | |||
332 333 334 335 336 337 338 | clazz.style = 0; clazz.cbClsExtra = 0; clazz.cbWndExtra = 0; clazz.hInstance = TclWinGetTclInstance(); clazz.hbrBackground = NULL; clazz.lpszMenuName = NULL; clazz.lpszClassName = className; | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 | clazz.style = 0; clazz.cbClsExtra = 0; clazz.cbWndExtra = 0; clazz.hInstance = TclWinGetTclInstance(); clazz.hbrBackground = NULL; clazz.lpszMenuName = NULL; clazz.lpszClassName = className; clazz.lpfnWndProc = (void *)NotifierProc; clazz.hIcon = NULL; clazz.hCursor = NULL; RegisterClassW(&clazz); tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName, clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, clazz.hInstance, NULL); |
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 |
tspecPtr = NULL;
} else {
tspecPtr = &tspec;
tspecPtr->tv_sec = timePtr->tv_sec;
tspecPtr->tv_nsec = timePtr->tv_usec * 1000;
}
ret = pselect(numFdBits, &readableMask, &writableMask,
| | | | 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 |
tspecPtr = NULL;
} else {
tspecPtr = &tspec;
tspecPtr->tv_sec = timePtr->tv_sec;
tspecPtr->tv_nsec = timePtr->tv_usec * 1000;
}
ret = pselect(numFdBits, &readableMask, &writableMask,
&exceptionMask, tspecPtr, ¬ifierSigMask);
}
#else
pthread_sigmask(SIG_SETMASK, ¬ifierSigMask, NULL);
ret = select(numFdBits, &readableMask, &writableMask, &exceptionMask,
timePtr);
pthread_sigmask(SIG_BLOCK, &allSigMask, NULL);
#endif
if (ret == -1) {
/*
* In case a signal was caught during select(),
* perform work on async handlers now.
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 | * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclIO.h" /* To get Channel type declaration. */ #undef SUPPORTS_TTY #if defined(HAVE_TERMIOS_H) # define SUPPORTS_TTY 1 # include <termios.h> # ifdef HAVE_SYS_IOCTL_H | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclFileSystem.h" #include "tclIO.h" /* To get Channel type declaration. */ #undef SUPPORTS_TTY #if defined(HAVE_TERMIOS_H) # define SUPPORTS_TTY 1 # include <termios.h> # ifdef HAVE_SYS_IOCTL_H |
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
#endif /* SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
"%s not supported for this platform", (detail))); \
| | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
#endif /* SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
"%s not supported for this platform", (detail))); \
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (char *)NULL); \
}
/*
* Static routines for this file:
*/
static int FileBlockModeProc(void *instanceData, int mode);
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
/*
* This structure describes the channel type structure for file based IO:
*/
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
/*
* This structure describes the channel type structure for file based IO:
*/
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
FileInputProc,
FileOutputProc,
NULL, /* Deprecated. */
NULL, /* Set option proc. */
FileGetOptionProc,
FileWatchProc,
FileGetHandleProc,
FileCloseProc,
FileBlockModeProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
FileWideSeekProc,
NULL, /* Thread action proc. */
FileTruncateProc
};
#ifdef SUPPORTS_TTY
/*
* This structure describes the channel type structure for serial IO.
* Note that this type is a subclass of the "file" type.
*/
static const Tcl_ChannelType ttyChannelType = {
"tty",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
FileInputProc,
FileOutputProc,
NULL, /* Deprecated. */
TtySetOptionProc,
TtyGetOptionProc,
FileWatchProc,
FileGetHandleProc,
TtyCloseProc,
FileBlockModeProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
NULL, /* Seek proc. */
NULL, /* Thread action proc. */
NULL /* Truncate proc. */
};
#endif /* SUPPORTS_TTY */
/*
*----------------------------------------------------------------------
*
* FileBlockModeProc --
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockModeProc( | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
FileBlockModeProc(
void *instanceData, /* File state. */
int mode) /* The mode to set. Can be TCL_MODE_BLOCKING
* or TCL_MODE_NONBLOCKING. */
{
FileState *fsPtr = (FileState *)instanceData;
if (TclUnixSetBlockingMode(fsPtr->fd, mode) < 0) {
return errno;
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc( | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
FileInputProc(
void *instanceData, /* File state. */
char *buf, /* Where to store data read. */
int toRead, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
int bytesRead; /* How many bytes were actually read from the
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
static int
FileOutputProc(
void *instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
int written;
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 | * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int FileCloseProc( | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
* Closes the device of the channel.
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(
void *instanceData, /* File state. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
FileState *fsPtr = (FileState *)instanceData;
int errorCode = 0;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
* operations.
*
*----------------------------------------------------------------------
*/
static long long
FileWideSeekProc(
void *instanceData, /* File state. */
long long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_CUR or SEEK_END. */
int *errorCodePtr) /* To store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
long long newLoc;
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 |
{
Tcl_Channel channel = (Tcl_Channel)clientData;
Tcl_NotifyChannel(channel, mask);
}
static void
FileWatchProc(
| | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
{
Tcl_Channel channel = (Tcl_Channel)clientData;
Tcl_NotifyChannel(channel, mask);
}
static void
FileWatchProc(
void *instanceData, /* The file state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
FileState *fsPtr = (FileState *)instanceData;
/*
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( | | | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileGetHandleProc(
void *instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
void **handlePtr) /* Where to store the handle. */
{
FileState *fsPtr = (FileState *)instanceData;
if (direction & fsPtr->validMask) {
*handlePtr = INT2PTR(fsPtr->fd);
return TCL_OK;
}
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 | * A standard Tcl result. Also sets the supplied DString to the string * value of the option(s) returned. Sets error message if needed * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ | < < < < < < < < < < < < < < < | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
* A standard Tcl result. Also sets the supplied DString to the string
* value of the option(s) returned. Sets error message if needed
* (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static inline const char *
GetTypeFromMode(
int mode)
{
/*
* TODO: deduplicate with tclCmdAH.c
*/
|
| ︙ | ︙ | |||
627 628 629 630 631 632 633 |
/*
* TODO: merge with TIP 594 implementation (it's silly to have a
* duplicate!)
*/
TclNewObj(dictObj);
| | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
/*
* TODO: merge with TIP 594 implementation (it's silly to have a
* duplicate!)
*/
TclNewObj(dictObj);
#define STORE_ELEM(name, value) TclDictPut(NULL, dictObj, name, value)
STORE_ELEM("dev", Tcl_NewWideIntObj((long) statBuf.st_dev));
STORE_ELEM("ino", Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_ino));
STORE_ELEM("nlink", Tcl_NewWideIntObj((long) statBuf.st_nlink));
STORE_ELEM("uid", Tcl_NewWideIntObj((long) statBuf.st_uid));
STORE_ELEM("gid", Tcl_NewWideIntObj((long) statBuf.st_gid));
STORE_ELEM("size", Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_size));
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 | /* * Transfer dictionary to the DString. Note that we don't do this as * an element as this is an option that can't be retrieved with a * general probe. */ | | | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
/*
* Transfer dictionary to the DString. Note that we don't do this as
* an element as this is an option that can't be retrieved with a
* general probe.
*/
dictContents = TclGetStringFromObj(dictObj, &dictLength);
Tcl_DStringAppend(dsPtr, dictContents, dictLength);
Tcl_DecrRefCount(dictObj);
return TCL_OK;
}
if (valid) {
return TCL_OK;
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 | * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc( | | | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
* calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
TtySetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
TtyState *fsPtr = (TtyState *)instanceData;
size_t len, vlen;
TtyAttrs tty;
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
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));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
| | | | | | 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 |
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));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", (char *)NULL);
}
return TCL_ERROR;
}
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -xchar {\x11 \x13}
*/
if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
} else if (argc != 2) {
badXchar:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", (char *)NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
tcgetattr(fsPtr->fileState.fd, &iostate);
iostate.c_cc[VSTART] = argv[0][0];
iostate.c_cc[VSTOP] = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
Tcl_UniChar character = 0;
int charLen;
charLen = TclUtfToUniChar(argv[0], &character);
if ((character > 0xFF) || argv[0][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTART] = character;
charLen = TclUtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTOP] = character;
}
Tcl_Free(argv);
|
| ︙ | ︙ | |||
924 925 926 927 928 929 930 |
}
if ((argc % 2) == 1) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -ttycontrol: should be a list of"
" signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
| | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
}
if ((argc % 2) == 1) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -ttycontrol: should be a list of"
" signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", (char *)NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
ioctl(fsPtr->fileState.fd, TIOCMGET, &control);
for (i = 0; i < argc-1; i += 2) {
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
#endif /* TIOCSBRK & TIOCCBRK */
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
| | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 |
#endif /* TIOCSBRK & TIOCCBRK */
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", (char *)NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
} /* -ttycontrol options loop */
ioctl(fsPtr->fileState.fd, TIOCMSET, &control);
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
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",
| | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 |
fsPtr->closeMode = CLOSE_DISCARD;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -closemode: must be"
" default, discard, or drain", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", (char *)NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 |
memcpy(&iostate, &fsPtr->initState, sizeof(struct termios));
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
| | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
memcpy(&iostate, &fsPtr->initState, sizeof(struct termios));
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", (char *)NULL);
}
return TCL_ERROR;
}
if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't update serial terminal control state: %s",
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc( | | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
* (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
TtyGetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
TtyState *fsPtr = (TtyState *)instanceData;
size_t len;
char buf[3*TCL_INTEGER_SPACE + 16];
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
&parity,
&ttyPtr->data,
&ttyPtr->stop, &end);
if ((i != 4) || (mode[end] != '\0')) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s: should be baud,parity,data,stop", bad));
| | < | | > | > > | | < < < < < < | | | | 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 |
&parity,
&ttyPtr->data,
&ttyPtr->stop, &end);
if ((i != 4) || (mode[end] != '\0')) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s: should be baud,parity,data,stop", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL);
}
return TCL_ERROR;
}
/*
* Only allow setting mark/space parity on platforms that support it Make
* sure to allow for the case where strchr is a macro. [Bug: 5089]
*
* We cannot if/else/endif the strchr arguments, it has to be the whole
* function. On AIX this function is apparently a macro, and macros do
* not allow preprocessor directives in their arguments.
*/
#ifdef PAREXT
#define PARITY_CHARS "noems"
#define PARITY_MSG "n, o, e, m, or s"
#else
#define PARITY_CHARS "noe"
#define PARITY_MSG "n, o, or e"
#endif /* PAREXT */
if (strchr(PARITY_CHARS, parity) == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s parity: should be %s", bad, PARITY_MSG));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL);
}
return TCL_ERROR;
}
ttyPtr->parity = parity;
if ((ttyPtr->data < 5) || (ttyPtr->data > 8)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s data: should be 5, 6, 7, or 8", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL);
}
return TCL_ERROR;
}
if ((ttyPtr->stop < 0) || (ttyPtr->stop > 2)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s stop: should be 1 or 2", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 |
{
int fd, channelPermissions;
TtyState *fsPtr;
const char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
const Tcl_ChannelType *channelTypePtr;
| | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 |
{
int fd, channelPermissions;
TtyState *fsPtr;
const char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
const Tcl_ChannelType *channelTypePtr;
switch (mode & O_ACCMODE) {
case O_RDONLY:
channelPermissions = TCL_READABLE;
break;
case O_WRONLY:
channelPermissions = TCL_WRITABLE;
break;
case O_RDWR:
|
| ︙ | ︙ | |||
1786 1787 1788 1789 1790 1791 1792 1793 1794 |
Tcl_Panic("TclpOpenFileChannel: invalid mode value");
return NULL;
}
native = (const char *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
TclGetString(pathPtr), "\": filename is invalid on this platform",
| > > > > > > > > > > > > > > > > > > > > | | 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 |
Tcl_Panic("TclpOpenFileChannel: invalid mode value");
return NULL;
}
native = (const char *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
if (interp != (Tcl_Interp *) NULL) {
/*
* We need this just to ensure we return the correct error messages under
* some circumstances (relative paths only), so because the normalization
* is very expensive, don't invoke it for native or absolute paths.
* Note: since paths starting with ~ are absolute, it also considers tilde expansion,
* (proper error message of tests *io-40.17 "tilde substitution in open")
*/
if (
(
(
!TclFSCwdIsNative() &&
(Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE)
) ||
(*TclGetString(pathPtr) == '~') /* possible tilde expansion */
) &&
Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL
) {
return NULL;
}
Tcl_AppendResult(interp, "couldn't open \"",
TclGetString(pathPtr), "\": filename is invalid on this platform",
(char *)NULL);
}
return NULL;
}
#ifdef DJGPP
SET_BITS(mode, O_BINARY);
#endif
|
| ︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 |
const char *chanID, /* String that identifies file. */
int forWriting, /* 1 means the file is going to be used for
* writing, 0 means for reading. */
TCL_UNUSED(int), /* Obsolete argument.
* Ignored, we always check that
* the channel is open for the requested
* mode. */
| | | | | 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 |
const char *chanID, /* String that identifies file. */
int forWriting, /* 1 means the file is going to be used for
* writing, 0 means for reading. */
TCL_UNUSED(int), /* Obsolete argument.
* Ignored, we always check that
* the channel is open for the requested
* mode. */
void **filePtr) /* Store pointer to FILE structure here. */
{
Tcl_Channel chan;
int chanMode, fd;
const Tcl_ChannelType *chanTypePtr;
void *data;
FILE *f;
chan = Tcl_GetChannel(interp, chanID, &chanMode);
if (chan == NULL) {
return TCL_ERROR;
}
if (forWriting && !(chanMode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" wasn't opened for writing", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE",
(char *)NULL);
return TCL_ERROR;
} else if (!forWriting && !(chanMode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" wasn't opened for reading", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE",
(char *)NULL);
return TCL_ERROR;
}
/*
* We allow creating a FILE * out of file based, pipe based and socket
* based channels. We currently do not allow any other channel types,
* because it is likely that stdio will not know what to do with them.
|
| ︙ | ︙ | |||
2119 2120 2121 2122 2123 2124 2125 |
*/
f = fdopen(fd, (forWriting ? "w" : "r"));
if (f == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot get a FILE * for \"%s\"", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL",
| | | | 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 |
*/
f = fdopen(fd, (forWriting ? "w" : "r"));
if (f == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot get a FILE * for \"%s\"", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL",
"FILE_FAILURE", (char *)NULL);
return TCL_ERROR;
}
*filePtr = f;
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" cannot be used to get a FILE *", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR",
(char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* FileTruncateProc --
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
/* See: <http://en.wikipedia.org/wiki/CPUID> */
#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64)
__asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */
| | | | | | | | | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
/* See: <http://en.wikipedia.org/wiki/CPUID> */
#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64)
__asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */
"cpuid \n\t"
"xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */
: "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
: "a"(index));
status = TCL_OK;
#elif defined(__i386__) || defined(_M_IX86)
__asm__ __volatile__("mov %%ebx, %%esi \n\t" /* save %ebx */
"cpuid \n\t"
"xchg %%esi, %%ebx \n\t" /* restore the old %ebx */
: "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
: "a"(index));
status = TCL_OK;
#else
(void)index;
(void)regsPtr;
#endif
return status;
}
|
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
| ︙ | ︙ | |||
240 241 242 243 244 245 246 |
return realpath(path, resolved);
}
#else
# define Realpath realpath
#endif /* PURIFY */
#ifndef NO_REALPATH
| < < < < < < < < < < < < < < < < < < | < < < < < < < | < | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
return realpath(path, resolved);
}
#else
# define Realpath realpath
#endif /* PURIFY */
#ifndef NO_REALPATH
# define haveRealpath 1
#endif /* NO_REALPATH */
#ifdef HAVE_FTS
#if defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
/* fts doesn't do stat64 */
# define noFtsStat 1
#else
# define noFtsStat 0
#endif
#endif /* HAVE_FTS */
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
480 481 482 483 484 485 486 |
switch ((int) (statBufPtr->st_mode & S_IFMT)) {
#ifndef DJGPP
case S_IFLNK: {
char linkBuf[MAXPATHLEN+1];
int length;
| | < | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
switch ((int) (statBufPtr->st_mode & S_IFMT)) {
#ifndef DJGPP
case S_IFLNK: {
char linkBuf[MAXPATHLEN+1];
int length;
length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */
if (length == -1) {
return TCL_ERROR;
}
linkBuf[length] = '\0';
if (symlink(linkBuf, dst) < 0) { /* INTL: Native. */
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
806 807 808 809 810 811 812 | * the pathname of the file that caused the error is stored in errorPtr. * Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". | | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 | * the pathname of the file that caused the error is stored in errorPtr. * Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". * ENOTDIR: path is not a directory. * * Side effects: * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *--------------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
950 951 952 953 954 955 956 |
* traversed (native). */
Tcl_DString *targetPtr, /* Pathname of directory to traverse in
* parallel with source directory (native). */
Tcl_DString *errorPtr, /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
int doRewind) /* Flag indicating that to ensure complete
| | | | | | | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 |
* traversed (native). */
Tcl_DString *targetPtr, /* Pathname of directory to traverse in
* parallel with source directory (native). */
Tcl_DString *errorPtr, /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
int doRewind) /* Flag indicating that to ensure complete
* traversal of source hierarchy, the readdir
* loop should be rewound whenever
* traverseProc has returned TCL_OK; this is
* required when traverseProc modifies the
* source hierarchy, e.g. by deleting
* files. */
{
Tcl_StatBuf statBuf;
const char *source, *errfile;
int result;
size_t targetLen, sourceLen;
#ifndef HAVE_FTS
int numProcessed = 0;
|
| ︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 |
if (TclGetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr = NULL;
const char *string;
Tcl_Size length;
| | | | 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 |
if (TclGetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr = NULL;
const char *string;
Tcl_Size length;
string = TclGetStringFromObj(attributePtr, &length);
if (Tcl_UtfToExternalDStringEx(interp, NULL, string, length, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
native = Tcl_DStringValue(&ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (groupPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set group for file \"%s\":"
" group \"%s\" does not exist",
TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP",
"NO_GROUP", (char *)NULL);
}
return TCL_ERROR;
}
gid = groupPtr->gr_gid;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
|
| ︙ | ︙ | |||
1583 1584 1585 1586 1587 1588 1589 |
if (TclGetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr = NULL;
const char *string;
Tcl_Size length;
| | | | 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 |
if (TclGetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr = NULL;
const char *string;
Tcl_Size length;
string = TclGetStringFromObj(attributePtr, &length);
if (Tcl_UtfToExternalDStringEx(interp, NULL, string, length, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
native = Tcl_DStringValue(&ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set owner for file \"%s\":"
" user \"%s\" does not exist",
TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN",
"NO_USER", (char *)NULL);
}
return TCL_ERROR;
}
uid = pwPtr->pw_uid;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
|
| ︙ | ︙ | |||
1695 1696 1697 1698 1699 1700 1701 |
newMode = (mode_t) (buf.st_mode & 0x00007FFF);
if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown permission string format \"%s\"",
modeStringPtr));
| | | 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 |
newMode = (mode_t) (buf.st_mode & 0x00007FFF);
if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown permission string format \"%s\"",
modeStringPtr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", (char *)NULL);
}
return TCL_ERROR;
}
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chmod(native, newMode); /* INTL: Native. */
|
| ︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 |
if (strlen(modeStringPtr) != 9) {
goto chmodStyleCheck;
}
newMode = 0;
for (i = 0; i < 9; i++) {
| | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 |
if (strlen(modeStringPtr) != 9) {
goto chmodStyleCheck;
}
newMode = 0;
for (i = 0; i < 9; i++) {
switch (modeStringPtr[i]) {
case 'r':
if ((i%3) != 0) {
goto chmodStyleCheck;
}
newMode |= (1<<(8-i));
break;
case 'w':
|
| ︙ | ︙ | |||
1844 1845 1846 1847 1848 1849 1850 |
return TCL_OK;
chmodStyleCheck:
/*
* We now check for an "ugoa+-=rwxst" style permissions string
*/
| | | | | | | | 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 |
return TCL_OK;
chmodStyleCheck:
/*
* We now check for an "ugoa+-=rwxst" style permissions string
*/
for (n = 0 ; modeStringPtr[n] != '\0' ; n += i) {
oldMode = *modePtr;
who = op = what = op_found = who_found = 0;
for (i = 0 ; modeStringPtr[n + i] != '\0' ; i++ ) {
if (!who_found) {
/* who */
switch (modeStringPtr[n + i]) {
case 'u':
who |= 0x9C0;
continue;
case 'g':
who |= 0x438;
continue;
case 'o':
who |= 0x207;
continue;
case 'a':
who |= 0xFFF;
continue;
}
}
who_found = 1;
if (who == 0) {
who = 0xFFF;
}
if (!op_found) {
/* op */
switch (modeStringPtr[n + i]) {
case '+':
op = 1;
op_found = 1;
continue;
case '-':
op = 2;
op_found = 1;
continue;
case '=':
op = 3;
op_found = 1;
continue;
default:
return TCL_ERROR;
}
}
/* what */
switch (modeStringPtr[n + i]) {
case 'r':
what |= 0x124;
continue;
case 'w':
what |= 0x92;
continue;
case 'x':
what |= 0x49;
continue;
case 's':
what |= 0xC00;
continue;
case 't':
what |= 0x200;
continue;
case ',':
break;
default:
return TCL_ERROR;
}
if (modeStringPtr[n + i] == ',') {
i++;
break;
}
}
switch (op) {
case 1:
*modePtr = oldMode | (who & what);
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
* normalized. I.e. this is not the index of
* the byte just after the separator. */
{
const char *currentPathEndPosition;
char cur;
Tcl_Size pathLen;
| | | 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
* normalized. I.e. this is not the index of
* the byte just after the separator. */
{
const char *currentPathEndPosition;
char cur;
Tcl_Size pathLen;
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_DString ds;
const char *nativePath;
#ifndef NO_REALPATH
char normPath[MAXPATHLEN];
#endif
currentPathEndPosition = path + nextCheckpoint;
|
| ︙ | ︙ | |||
2063 2064 2065 2066 2067 2068 2069 |
* Call 'realpath' to obtain a canonical path.
*/
#ifndef NO_REALPATH
if (haveRealpath) {
if (nextCheckpoint == 0) {
/*
| | | 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
* Call 'realpath' to obtain a canonical path.
*/
#ifndef NO_REALPATH
if (haveRealpath) {
if (nextCheckpoint == 0) {
/*
* The path contains at most one component, e.g. '/foo' or '/',
* so there is nothing to resolve. Also, on some platforms
* 'Realpath' transforms an empty string into the normalized pwd,
* which is the wrong answer.
*/
return 0;
}
|
| ︙ | ︙ | |||
2094 2095 2096 2097 2098 2099 2100 | Tcl_DStringFree(&ds); /* * Uncommenting this would mean that this native filesystem * routine claims the path is normalized if the file exists, * which would permit the caller to avoid iterating through | | | 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 |
Tcl_DStringFree(&ds);
/*
* Uncommenting this would mean that this native filesystem
* routine claims the path is normalized if the file exists,
* which would permit the caller to avoid iterating through
* other filesystems. Saving lots of calls is
* probably worth the extra access() time, but in the common
* case that no other filesystems are registered this is an
* unnecessary expense.
*
if (0 == access(normPath, F_OK)) {
return pathLen;
}
|
| ︙ | ︙ | |||
2204 2205 2206 2207 2208 2209 2210 |
Tcl_Size length;
/*
* We should also check against making more than TMP_MAX of these.
*/
if (dirObj) {
| | | | | 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 |
Tcl_Size length;
/*
* We should also check against making more than TMP_MAX of these.
*/
if (dirObj) {
string = TclGetStringFromObj(dirObj, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &templ, NULL) != TCL_OK) {
return -1;
}
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */
}
TclDStringAppendLiteral(&templ, "/");
if (basenameObj) {
string = TclGetStringFromObj(basenameObj, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &tmp, NULL) != TCL_OK) {
Tcl_DStringFree(&tmp);
return -1;
}
TclDStringAppendDString(&templ, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&templ, "tcl");
}
TclDStringAppendLiteral(&templ, "_XXXXXX");
#ifdef HAVE_MKSTEMPS
if (extensionObj) {
string = TclGetStringFromObj(extensionObj, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &tmp, NULL) != TCL_OK) {
Tcl_DStringFree(&templ);
return -1;
}
TclDStringAppendDString(&templ, &tmp);
fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
|
| ︙ | ︙ |
Changes to unix/tclUnixFile.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclFileSystem.h" | | > | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry, const char* nativeName, Tcl_GlobTypeData *types); /* *--------------------------------------------------------------------------- * * TclpFindExecutable -- * * This function computes the absolute path name of the current |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
}
#else
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
| < | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
}
#else
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
Tcl_Obj *obj;
if (argv0 == NULL) {
return;
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
*/
if ((access(name, X_OK) == 0) /* INTL: Native. */
&& (TclOSstat(name, &statBuf) == 0) /* INTL: Native. */
&& S_ISREG(statBuf.st_mode)) {
goto gotName;
}
| | | < | | < < | 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 |
*/
if ((access(name, X_OK) == 0) /* INTL: Native. */
&& (TclOSstat(name, &statBuf) == 0) /* INTL: Native. */
&& S_ISREG(statBuf.st_mode)) {
goto gotName;
}
if (p[0] == '\0') {
break;
} else if (p[1] == 0) {
p = "./";
} else {
p++;
}
}
TclNewObj(obj);
TclSetObjNameOfExecutable(obj, NULL);
goto done;
/*
* If the name starts with "/" then just store it
*/
gotName:
#ifdef DJGPP
if (name[1] == ':')
#else
if (name[0] == '/')
#endif
{
Tcl_ExternalToUtfDStringEx(NULL, NULL, name, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &utfName, NULL);
TclSetObjNameOfExecutable(Tcl_DStringToObj(&utfName), NULL);
goto done;
}
if (TclpGetCwd(NULL, &cwd) == NULL) {
TclNewObj(obj);
TclSetObjNameOfExecutable(obj, NULL);
goto done;
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
Tcl_DStringFree(&cwd);
TclDStringAppendDString(&buffer, &nameString);
Tcl_DStringFree(&nameString);
| < | | < < | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
Tcl_DStringFree(&cwd);
TclDStringAppendDString(&buffer, &nameString);
Tcl_DStringFree(&nameString);
Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(&buffer), TCL_INDEX_NONE,
TCL_ENCODING_PROFILE_TCL8, &utfName, NULL);
TclSetObjNameOfExecutable(Tcl_DStringToObj(&utfName), NULL);
done:
Tcl_DStringFree(&buffer);
}
#endif
/*
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 |
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
TclDIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
| | | < | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
TclDIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
Tcl_Size dirLength, nativeDirLen;
int matchHidden, matchHiddenPat;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
|
| ︙ | ︙ | |||
985 986 987 988 989 990 991 |
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
| | | 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 |
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = TclGetStringFromObj(transPtr, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, target, length, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return NULL;
}
target = Tcl_DStringValue(&ds);
Tcl_DecrRefCount(transPtr);
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 |
{
char *nativePathPtr;
const char *str;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
Tcl_Size len;
| | | | | 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 |
{
char *nativePathPtr;
const char *str;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
Tcl_Size len;
if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) {
/*
* The cwd is native (or path is absolute), use the translated path
* without worrying about normalization (this will also usually be
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
} else {
/*
* Make sure the normalized path is set.
*/
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetStringFromObj(validPathPtr, &len);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, str, len, 0, &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)) {
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation. * All rights reserved. */ #include "tclInt.h" #ifdef HAVE_LANGINFO # include <langinfo.h> | < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation. * All rights reserved. */ #include "tclInt.h" #ifdef HAVE_LANGINFO # include <langinfo.h> #endif #include <sys/resource.h> #if defined(__FreeBSD__) && defined(__GNUC__) # include <floatingpoint.h> #endif #if defined(__bsdi__) # include <sys/param.h> |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 |
#define NUMPROCESSORS 15
static const char *const processors[NUMPROCESSORS] = {
"i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64"
};
typedef struct {
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
#define NUMPROCESSORS 15
static const char *const processors[NUMPROCESSORS] = {
"i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64"
};
typedef struct {
union {
unsigned int dwOemId;
struct {
int wProcessorArchitecture;
int wReserved;
};
};
unsigned int dwPageSize;
void *lpMinimumApplicationAddress;
void *lpMaximumApplicationAddress;
void *dwActiveProcessorMask;
unsigned int dwNumberOfProcessors;
unsigned int dwProcessorType;
unsigned int dwAllocationGranularity;
int wProcessorLevel;
int wProcessorRevision;
} SYSTEM_INFO;
typedef struct {
unsigned int dwOSVersionInfoSize;
unsigned int dwMajorVersion;
unsigned int dwMinorVersion;
unsigned int dwBuildNumber;
unsigned int dwPlatformId;
wchar_t szCSDVersion[128];
} OSVERSIONINFOW;
#endif
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
#endif
|
| ︙ | ︙ | |||
96 97 98 99 100 101 102 | #endif /* * Default directory in which to look for Tcl library scripts. The symbol is * defined by Makefile. */ | | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | #endif /* * Default directory in which to look for Tcl library scripts. The symbol is * defined by Makefile. */ static const char defaultLibraryDir[] = TCL_LIBRARY; /* * Directory in which to look for packages (each package is typically * installed as a subdirectory of this directory). The symbol is defined by * Makefile. */ static const char pkgPath[] = TCL_PACKAGE_PATH; /* * The following table is used to map from Unix locale strings to encoding * files. If HAVE_LANGINFO is defined, then this is a fallback table when the * result from nl_langinfo isn't a recognized encoding. Otherwise this is the * first list checked for a mapping from env encoding to Tcl encoding name. */ |
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
{"zh_tw.big5", "big5"},
};
#ifdef HAVE_COREFOUNDATION
static int MacOSXGetLibraryPath(Tcl_Interp *interp,
int maxPathLen, char *tclLibPath);
#endif /* HAVE_COREFOUNDATION */
| < < < < < < < < < < < < < < < | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
{"zh_tw.big5", "big5"},
};
#ifdef HAVE_COREFOUNDATION
static int MacOSXGetLibraryPath(Tcl_Interp *interp,
int maxPathLen, char *tclLibPath);
#endif /* HAVE_COREFOUNDATION */
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
* Initialize all the platform-dependent things like signals and
|
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
* In case the initial locale is not "C", ensure that the numeric
* processing is done in "C" locale regardless. This is needed because Tcl
* relies on routines like strtol/strtoul, but should not have locale dependent
* behavior.
*/
setlocale(LC_NUMERIC, "C");
| < < < < < < < < < < | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
* In case the initial locale is not "C", ensure that the numeric
* processing is done in "C" locale regardless. This is needed because Tcl
* relies on routines like strtol/strtoul, but should not have locale dependent
* behavior.
*/
setlocale(LC_NUMERIC, "C");
}
/*
*---------------------------------------------------------------------------
*
* TclpInitLibraryPath --
*
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
/*
* Note lengthPtr is (size_t *) which is unsigned so cannot
* pass directly to Tcl_GetStringFromObj.
* TODO - why is the type size_t anyways?
*/
Tcl_Size length;
| | | 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 |
/*
* Note lengthPtr is (size_t *) which is unsigned so cannot
* pass directly to Tcl_GetStringFromObj.
* TODO - why is the type size_t anyways?
*/
Tcl_Size length;
str = TclGetStringFromObj(pathPtr, &length);
*lengthPtr = length;
*valuePtr = (char *)Tcl_Alloc(length + 1);
memcpy(*valuePtr, str, length + 1);
Tcl_DecrRefCount(pathPtr);
}
/*
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
static const char *
SearchKnownEncodings(
const char *encoding)
{
int left = 0;
int right = sizeof(localeTable)/sizeof(LocaleTable);
while (left < right) {
int test = (left + right)/2;
int code = strcmp(localeTable[test].lang, encoding);
if (code == 0) {
return localeTable[test].encoding;
}
if (code < 0) {
left = test+1;
} else {
| > > > > | | 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 |
static const char *
SearchKnownEncodings(
const char *encoding)
{
int left = 0;
int right = sizeof(localeTable)/sizeof(LocaleTable);
/* Here, search for i in the interval left <= i < right. */
while (left < right) {
int test = (left + right)/2;
int code = strcmp(localeTable[test].lang, encoding);
if (code == 0) {
/* Found it at i == test. */
return localeTable[test].encoding;
}
if (code < 0) {
/* Restrict the search to the interval test < i < right. */
left = test+1;
} else {
/* Restrict the search to the interval left <= i < test. */
right = test;
}
}
return NULL;
}
const char *
Tcl_GetEncodingNameFromEnvironment(
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 | * Side effects: * Sets "tclDefaultLibrary", "tcl_pkgPath", and "tcl_platform" Tcl * variables. * *---------------------------------------------------------------------- */ | | | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 | * Side effects: * Sets "tclDefaultLibrary", "tcl_pkgPath", and "tcl_platform" Tcl * variables. * *---------------------------------------------------------------------- */ #if defined(HAVE_COREFOUNDATION) /* * Helper because whether CFLocaleCopyCurrent and CFLocaleGetIdentifier are * strongly or weakly bound varies by version of OSX, triggering warnings. */ static inline void InitMacLocaleInfoVar( |
| ︙ | ︙ | |||
771 772 773 774 775 776 777 |
if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) {
Tcl_ResetResult(interp);
}
Tcl_SetVar2(interp, "::tcl::mac::locale", NULL, loc, TCL_GLOBAL_ONLY);
}
CFRelease(localeRef);
}
| | > | < < > < < < | | | < < < > > | < | < > | < < < < < < < | < < < | < < < < > < | > > > > > | > | | | > | | | | < | | 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 |
if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) {
Tcl_ResetResult(interp);
}
Tcl_SetVar2(interp, "::tcl::mac::locale", NULL, loc, TCL_GLOBAL_ONLY);
}
CFRelease(localeRef);
}
#endif /*defined(HAVE_COREFOUNDATION)*/
void
TclpSetVariables(
Tcl_Interp *interp)
{
#ifdef __CYGWIN__
SYSTEM_INFO sysInfo;
static OSVERSIONINFOW osInfo;
static int osInfoInitialized = 0;
char buffer[TCL_INTEGER_SPACE * 2];
#elif !defined(NO_UNAME)
struct utsname name;
#endif
int unameOK;
const char *p, *q;
Tcl_Obj *pkgListObj = Tcl_NewObj();
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
/*
* Set msgcat fallback locale to current CFLocale identifier.
*/
InitMacLocaleInfoVar(CFLocaleCopyCurrent, CFLocaleGetIdentifier, interp);
if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
const char *str;
CFBundleRef bundleRef;
Tcl_DString ds;
Tcl_SetVar2(interp, "tclDefaultLibrary", NULL, tclLibPath, TCL_GLOBAL_ONLY);
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(tclLibPath, -1));
str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
if ((str != NULL) && (str[0] != '\0')) {
p = Tcl_DStringValue(&ds);
while ((q = strchr(p, ':')) != NULL) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, q-p));
p = q+1;
}
if (*p) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1));
}
Tcl_DStringFree(&ds);
}
bundleRef = CFBundleGetMainBundle();
if (bundleRef) {
CFURLRef frameworksURL;
Tcl_StatBuf statBuf;
frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(tclLibPath, -1));
}
CFRelease(frameworksURL);
}
frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(tclLibPath, -1));
}
CFRelease(frameworksURL);
}
}
}
#endif /* HAVE_COREFOUNDATION */
p = pkgPath;
while ((q = strchr(p, ':')) != NULL) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, q-p));
p = q+1;
}
if (*p) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1));
}
Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY);
{
/* Some platforms build configure scripts expect ~ expansion so do that */
Tcl_Obj *origPaths;
Tcl_Obj *resolvedPaths;
origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
resolvedPaths = TclResolveTildePathList(origPaths);
if (resolvedPaths != origPaths && resolvedPaths != NULL) {
Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY);
}
}
#ifdef DJGPP
Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
|
| ︙ | ︙ | |||
916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
processors[sysInfo.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
#elif !defined NO_UNAME
if (uname(&name) >= 0) {
const char *native;
unameOK = 1;
native = Tcl_ExternalToUtfDString(NULL, name.sysname, TCL_INDEX_NONE, &ds);
Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
| > | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 |
processors[sysInfo.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
#elif !defined NO_UNAME
if (uname(&name) >= 0) {
const char *native;
Tcl_DString ds;
unameOK = 1;
native = Tcl_ExternalToUtfDString(NULL, name.sysname, TCL_INDEX_NONE, &ds);
Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
* Copy the username of the real user (according to getuid()) into
* tcl_platform(user).
*/
{
struct passwd *pwEnt = TclpGetPwUid(getuid());
const char *user;
if (pwEnt == NULL) {
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, TCL_INDEX_NONE, &ds);
}
| > | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 |
* Copy the username of the real user (according to getuid()) into
* tcl_platform(user).
*/
{
struct passwd *pwEnt = TclpGetPwUid(getuid());
const char *user;
Tcl_DString ds;
if (pwEnt == NULL) {
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, TCL_INDEX_NONE, &ds);
}
|
| ︙ | ︙ |
Changes to unix/tclUnixNotfy.c.
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
#if defined(NOTIFIER_EPOLL) && defined(HAVE_EVENTFD)
uint64_t eventFdVal = 1;
if (write(tsdPtr->triggerEventFd, &eventFdVal,
sizeof(eventFdVal)) != sizeof(eventFdVal)) {
Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd",
| | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
#if defined(NOTIFIER_EPOLL) && defined(HAVE_EVENTFD)
uint64_t eventFdVal = 1;
if (write(tsdPtr->triggerEventFd, &eventFdVal,
sizeof(eventFdVal)) != sizeof(eventFdVal)) {
Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd",
tsdPtr);
}
#else
if (write(tsdPtr->triggerPipe[1], "", 1) != 1) {
Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerPipe",
tsdPtr);
}
#endif /* NOTIFIER_EPOLL && HAVE_EVENTFD */
#endif /* NOTIFIER_SELECT */
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
* Remove the ThreadSpecificData structure of this thread from the
* waiting list. This prevents us from continuously spinning on
* epoll_wait until the other threads runs and services the file
* event.
*/
if (tsdPtr->prevPtr) {
| | | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
* Remove the ThreadSpecificData structure of this thread from the
* waiting list. This prevents us from continuously spinning on
* epoll_wait until the other threads runs and services the file
* event.
*/
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
waitingListPtr = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
tsdPtr->pollState = 0;
}
#ifdef __CYGWIN__
PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
|
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | #endif /* NOTIFIER_SELECT */ /* *---------------------------------------------------------------------- * * TclpNotifierData -- * | | | | 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 |
#endif /* NOTIFIER_SELECT */
/*
*----------------------------------------------------------------------
*
* TclpNotifierData --
*
* This function returns a void pointer to be associated
* with a Tcl_AsyncHandler.
*
* Results:
* For the epoll and kqueue notifiers, this function returns the
* thread specific data. Otherwise NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpNotifierData(void)
{
#if defined(NOTIFIER_EPOLL) || defined(NOTIFIER_KQUEUE)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
return tsdPtr;
#else
return NULL;
#endif
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to unix/tclUnixPipe.c.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 |
/*
* This structure describes the channel type structure for command pipe based
* I/O:
*/
static const Tcl_ChannelType pipeChannelType = {
| | | | | | | | | | | | | | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 |
/*
* This structure describes the channel type structure for command pipe based
* I/O:
*/
static const Tcl_ChannelType pipeChannelType = {
"pipe",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
PipeInputProc,
PipeOutputProc,
NULL, /* Deprecated. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
PipeWatchProc,
PipeGetHandleProc,
PipeClose2Proc,
PipeBlockModeProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
NULL, /* Seek proc. */
NULL, /* Thread action proc. */
NULL /* Truncation proc. */
};
/*
*----------------------------------------------------------------------
*
* TclpMakeFile --
*
|
| ︙ | ︙ | |||
424 425 426 427 428 429 430 |
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
| | | | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
Tcl_DString *volatile dsArray;
char **volatile newArgv;
int pid;
size_t i;
#if defined(HAVE_POSIX_SPAWNP)
int childErrno;
static int use_spawn = -1;
#endif
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 | posix_spawn_file_actions_init(&actions); posix_spawnattr_init(&attr); sigfillset(&sigs); sigdelset(&sigs, SIGKILL); sigdelset(&sigs, SIGSTOP); | | < | | | | 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 | posix_spawn_file_actions_init(&actions); posix_spawnattr_init(&attr); sigfillset(&sigs); sigdelset(&sigs, SIGKILL); sigdelset(&sigs, SIGSTOP); posix_spawnattr_setflags(&attr, POSIX_SPAWN_SETSIGDEF #ifdef POSIX_SPAWN_USEVFORK | POSIX_SPAWN_USEVFORK #endif ); posix_spawnattr_setsigdefault(&attr, &sigs); posix_spawn_file_actions_adddup2(&actions, GetFd(inputFile), 0); posix_spawn_file_actions_adddup2(&actions, GetFd(outputFile), 1); posix_spawn_file_actions_adddup2(&actions, GetFd(errorFile), 2); status = posix_spawnp(&pid, newArgv[0], &actions, &attr, newArgv, environ); childErrno = errno; posix_spawn_file_actions_destroy(&actions); posix_spawnattr_destroy(&attr); /* * Fork semantics: * - pid == 0: child process |
| ︙ | ︙ | |||
841 842 843 844 845 846 847 |
size_t numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated
* by the caller, freed when the channel is
* closed or the processes are detached (in a
* background exec). */
{
char channelName[16 + TCL_INTEGER_SPACE];
| | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 |
size_t numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated
* by the caller, freed when the channel is
* closed or the processes are detached (in a
* background exec). */
{
char channelName[16 + TCL_INTEGER_SPACE];
int fd;
PipeState *statePtr = (PipeState *)Tcl_Alloc(sizeof(PipeState));
int mode;
statePtr->inFile = readFile;
statePtr->outFile = writeFile;
statePtr->errorFile = errorFile;
statePtr->numPids = numPids;
|
| ︙ | ︙ | |||
865 866 867 868 869 870 871 |
}
/*
* Use one of the fds associated with the channel as the channel id.
*/
if (readFile) {
| | | | | | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 |
}
/*
* Use one of the fds associated with the channel as the channel id.
*/
if (readFile) {
fd = GetFd(readFile);
} else if (writeFile) {
fd = GetFd(writeFile);
} else if (errorFile) {
fd = GetFd(errorFile);
} else {
fd = 0;
}
/*
* For backward compatibility with previous versions of Tcl, we use
* "file%d" as the base name for pipes even though it would be more
* natural to use "pipe%d".
*/
snprintf(channelName, sizeof(channelName), "file%d", fd);
statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
statePtr, mode);
return statePtr->channel;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
*/
/*
* Bug ad5a57f2f271: Tcl_NotifyChannel is not a Tcl_FileProc,
* so do not pass it to directly to Tcl_CreateFileHandler.
* Instead, pass a wrapper which is a Tcl_FileProc.
*/
static void
PipeWatchNotifyChannelWrapper(
void *clientData,
int mask)
{
Tcl_Channel channel = (Tcl_Channel)clientData;
Tcl_NotifyChannel(channel, mask);
}
static void
PipeWatchProc(
void *instanceData, /* The pipe state. */
int mask) /* Events of interest; an OR-ed combination of
| > > | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
*/
/*
* Bug ad5a57f2f271: Tcl_NotifyChannel is not a Tcl_FileProc,
* so do not pass it to directly to Tcl_CreateFileHandler.
* Instead, pass a wrapper which is a Tcl_FileProc.
*/
static void
PipeWatchNotifyChannelWrapper(
void *clientData,
int mask)
{
Tcl_Channel channel = (Tcl_Channel)clientData;
Tcl_NotifyChannel(channel, mask);
}
static void
PipeWatchProc(
void *instanceData, /* The pipe state. */
int mask) /* Events of interest; an OR-ed combination of
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 |
{
Tcl_Channel chan;
PipeState *pipePtr;
size_t i;
Tcl_Obj *resultPtr;
if (objc > 2) {
| | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 |
{
Tcl_Channel chan;
PipeState *pipePtr;
size_t i;
Tcl_Obj *resultPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channel?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
} else {
/*
|
| ︙ | ︙ |
Changes to unix/tclUnixPort.h.
| ︙ | ︙ | |||
555 556 557 558 559 560 561 | /* *--------------------------------------------------------------------------- * Include AvailabilityMacros.h here (when available) to ensure any symbolic * MAC_OS_X_VERSION_* constants passed on the command line are translated. *--------------------------------------------------------------------------- */ | < | < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
/*
*---------------------------------------------------------------------------
* Include AvailabilityMacros.h here (when available) to ensure any symbolic
* MAC_OS_X_VERSION_* constants passed on the command line are translated.
*---------------------------------------------------------------------------
*/
# include <AvailabilityMacros.h>
/*
*---------------------------------------------------------------------------
* Support for weak import.
*---------------------------------------------------------------------------
*/
# ifdef HAVE_WEAK_IMPORT
# ifndef WEAK_IMPORT_ATTRIBUTE
# define WEAK_IMPORT_ATTRIBUTE __attribute__((weak_import))
# endif
# endif /* HAVE_WEAK_IMPORT */
/*
* For now, test exec-17.1 fails (I/O setup after closing stdout) with
* posix_spawnp(), but the classic implementation (based on fork()+execvp())
* works well under macOS.
*/
# undef HAVE_POSIX_SPAWNP
# undef HAVE_VFORK
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 | /* *--------------------------------------------------------------------------- * The following macros and declaration wrap the C runtime library functions. *--------------------------------------------------------------------------- */ | < < | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 | /* *--------------------------------------------------------------------------- * The following macros and declaration wrap the C runtime library functions. *--------------------------------------------------------------------------- */ #if !defined(TCL_THREADS) || TCL_THREADS # include <pthread.h> #endif /* TCL_THREADS */ /* FIXME - Hyper-enormous platform assumption! */ #ifndef AF_INET6 # define AF_INET6 10 |
| ︙ | ︙ |
Changes to unix/tclUnixSock.c.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
TcpFdList fds; /* The file descriptors of the sockets. */
int interest; /* Event types of interest */
/*
* Only needed for server sockets
*/
| | < | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
TcpFdList fds; /* The file descriptors of the sockets. */
int interest; /* Event types of interest */
/*
* Only needed for server sockets
*/
Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */
void *acceptProcData; /* The data for the accept proc. */
/*
* Only needed for client sockets
*/
struct addrinfo *addrlist; /* Addresses to connect to. */
|
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
/*
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
| | | | | | | | | | | | | | | | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
/*
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
TcpInputProc,
TcpOutputProc,
NULL, /* Deprecated. */
TcpSetOptionProc,
TcpGetOptionProc,
TcpWatchProc,
TcpGetHandleProc,
TcpClose2Proc,
TcpBlockModeProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
NULL, /* Seek proc. */
TcpThreadActionProc,
NULL /* Truncate proc. */
};
/*
* The following variable holds the network name of this host.
*/
static TclInitProcessGlobalValueProc InitializeHostName;
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | } #endif /* * ---------------------------------------------------------------------- * * InitializeHostName -- * | | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | } #endif /* * ---------------------------------------------------------------------- * * InitializeHostName -- * * This routine sets the process global value of the name of the local * host on which the process is running. * * Results: * None. * * ---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
#ifndef NO_UNAME
struct utsname u;
struct hostent *hp;
memset(&u, (int) 0, sizeof(struct utsname));
if (uname(&u) >= 0) { /* INTL: Native. */
| | | | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
#ifndef NO_UNAME
struct utsname u;
struct hostent *hp;
memset(&u, (int) 0, sizeof(struct utsname));
if (uname(&u) >= 0) { /* INTL: Native. */
hp = TclpGetHostByName(u.nodename); /* INTL: Native. */
if (hp == NULL) {
/*
* Sometimes the nodename is fully qualified, but gets truncated
* as it exceeds SYS_NMLN. See if we can just get the immediate
* nodename and get a proper answer that way.
*/
char *dot = strchr(u.nodename, '.');
if (dot != NULL) {
char *node = (char *)Tcl_Alloc(dot - u.nodename + 1);
memcpy(node, u.nodename, dot - u.nodename);
node[dot - u.nodename] = '\0';
hp = TclpGetHostByName(node);
Tcl_Free(node);
}
}
if (hp != NULL) {
native = hp->h_name;
} else {
native = u.nodename;
}
}
#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
*
* There is no portable macro for the maximum length of host names
* returned by gethostbyname(). We should only trust SYS_NMLN if it is at
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
if (mode == TCL_MODE_BLOCKING) {
CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
SET_BITS(statePtr->flags, TCP_NONBLOCKING);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
| | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
if (mode == TCL_MODE_BLOCKING) {
CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
SET_BITS(statePtr->flags, TCP_NONBLOCKING);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
statePtr->cachedBlocking = mode;
return 0;
}
if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) {
return errno;
}
return 0;
}
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 | * * EWOULDBLOCK: if connect is still in progress * * ENOTCONN: if connect failed. This would be the error message * of a recv or sendto syscall so this is emulated here. * * NULL: Called by a background operation. Do not block and do not * return any error code. * * Results: | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 | * * EWOULDBLOCK: if connect is still in progress * * ENOTCONN: if connect failed. This would be the error message * of a recv or sendto syscall so this is emulated here. * * NULL: Called by a background operation. Do not block and do not * return any error code. * * Results: * 0 if the connection has completed, -1 if still in progress or there is * an error. * * Side effects: * Processes socket events off the system queue. May process * asynchronous connects. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
* In socket test mode do not continue with the connect.
* Exceptions are:
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
*/
if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
| | | | | | | | | | | | | | | | | | | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
* In socket test mode do not continue with the connect.
* Exceptions are:
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
*/
if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
&& !(errorCodePtr != NULL
&& !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) {
*errorCodePtr = EWOULDBLOCK;
return -1;
}
if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
timeout = 0;
} else {
timeout = -1;
}
do {
if (TclUnixWaitForFile(statePtr->fds.fd,
TCL_WRITABLE | TCL_EXCEPTION, timeout) != 0) {
TcpConnect(NULL, statePtr);
}
/*
* Do this only once in the nonblocking case and repeat it until the
* socket is final when blocking.
*/
} while (timeout == -1 && GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT));
if (errorCodePtr != NULL) {
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
*errorCodePtr = EAGAIN;
return -1;
} else if (statePtr->connectError != 0) {
*errorCodePtr = ENOTCONN;
return -1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
while (fds != NULL) {
TcpFdList *next = fds->next;
Tcl_Free(fds);
fds = next;
}
if (statePtr->addrlist != NULL) {
| | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
while (fds != NULL) {
TcpFdList *next = fds->next;
Tcl_Free(fds);
fds = next;
}
if (statePtr->addrlist != NULL) {
freeaddrinfo(statePtr->addrlist);
}
if (statePtr->myaddrlist != NULL) {
freeaddrinfo(statePtr->myaddrlist);
}
Tcl_Free(statePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
#pragma GCC diagnostic ignored "-Wstrict-aliasing"
#endif
static inline int
IPv6AddressNeedsNumericRendering(
struct in6_addr addr)
{
if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) {
| | | | | | | | | | | | | | | | | | | | | | | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
#pragma GCC diagnostic ignored "-Wstrict-aliasing"
#endif
static inline int
IPv6AddressNeedsNumericRendering(
struct in6_addr addr)
{
if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) {
return 1;
}
/*
* The IN6_IS_ADDR_V4MAPPED macro has a problem with aliasing warnings on
* at least some versions of OSX.
*/
if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
return 0;
}
return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
&& addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
}
#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic pop
#endif
#endif /* NEED_FAKE_RFC2553 */
static void
TcpHostPortList(
Tcl_Interp *interp,
Tcl_DString *dsPtr,
address addr,
socklen_t salen)
{
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
char host[NI_MAXHOST], nhost[NI_MAXHOST], nport[NI_MAXSERV];
int flags = 0;
getnameinfo(&addr.sa, salen, nhost, sizeof(nhost), nport, sizeof(nport),
NI_NUMERICHOST | NI_NUMERICSERV);
Tcl_DStringAppendElement(dsPtr, nhost);
/*
* We don't want to resolve INADDR_ANY and sin6addr_any; they can
* sometimes cause problems (and never have a name).
*/
if (addr.sa.sa_family == AF_INET) {
if (addr.sa4.sin_addr.s_addr == INADDR_ANY) {
flags |= NI_NUMERICHOST;
}
#ifndef NEED_FAKE_RFC2553
} else if (addr.sa.sa_family == AF_INET6) {
if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) {
flags |= NI_NUMERICHOST;
}
#endif /* NEED_FAKE_RFC2553 */
}
/*
* Check if reverse DNS has been switched off globally.
*/
if (interp != NULL &&
Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) {
flags |= NI_NUMERICHOST;
}
if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0,
flags) == 0) {
/*
* Reverse mapping worked.
*/
Tcl_DStringAppendElement(dsPtr, host);
} else {
/*
* Reverse mapping failed - use the numeric rep once more.
*/
Tcl_DStringAppendElement(dsPtr, nhost);
}
Tcl_DStringAppendElement(dsPtr, nport);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
903 904 905 906 907 908 909 |
}
if ((len > 1) && (optionName[1] == 'e') &&
(strncmp(optionName, "-error", len) == 0)) {
socklen_t optlen = sizeof(int);
WaitForConnect(statePtr, NULL);
| | | | | | | | | | | | | | | | | | | | | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 |
}
if ((len > 1) && (optionName[1] == 'e') &&
(strncmp(optionName, "-error", len) == 0)) {
socklen_t optlen = sizeof(int);
WaitForConnect(statePtr, NULL);
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* Suppress errors as long as we are not done.
*/
errno = 0;
} else if (statePtr->connectError != 0) {
errno = statePtr->connectError;
statePtr->connectError = 0;
} else {
int err;
getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err,
&optlen);
errno = err;
}
if (errno != 0) {
Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE);
}
return TCL_OK;
}
if ((len > 1) && (optionName[1] == 'c') &&
(strncmp(optionName, "-connecting", len) == 0)) {
WaitForConnect(statePtr, NULL);
Tcl_DStringAppend(dsPtr,
GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE);
return TCL_OK;
}
if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
(strncmp(optionName, "-peername", len) == 0))) {
address peername;
socklen_t size = sizeof(peername);
WaitForConnect(statePtr, NULL);
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* In async connect output an empty string
*/
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
* Peername fetch succeeded - output list
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
}
| | | | | | | 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 |
* Peername fetch succeeded - output list
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
}
TcpHostPortList(interp, dsPtr, peername, size);
if (len) {
return TCL_OK;
}
Tcl_DStringEndSublist(dsPtr);
} else {
/*
* getpeername failed - but if we were asked for all the options
* (len==0), don't flag an error at that point because it could be
* an fconfigure request on a server socket (which have no peer).
* Same must be done on win&mac.
*/
if (len) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get peername: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
}
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
Tcl_DStringStartSublist(dsPtr);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* In async connect output an empty string
*/
| | | | | | | | | | | | | 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 |
Tcl_DStringStartSublist(dsPtr);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* In async connect output an empty string
*/
found = 1;
} else {
for (fds = &statePtr->fds; fds != NULL; fds = fds->next) {
size = sizeof(sockname);
if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) {
found = 1;
TcpHostPortList(interp, dsPtr, sockname, size);
}
}
}
if (found) {
if (len) {
return TCL_OK;
}
Tcl_DStringEndSublist(dsPtr);
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get sockname: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
if ((len == 0) || ((len > 1) && (optionName[1] == 'k') &&
(strncmp(optionName, "-keepalive", len) == 0))) {
int opt = 0;
|
| ︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 |
if (len > 0) {
return TCL_OK;
}
}
if (len > 0) {
return Tcl_BadChannelOption(interp, optionName,
| | | 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 |
if (len > 0) {
return TCL_OK;
}
}
if (len > 0) {
return Tcl_BadChannelOption(interp, optionName,
"connecting keepalive nodelay peername sockname");
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (statePtr->acceptProc != NULL) {
| | | | | | | | | | | | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 |
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (statePtr->acceptProc != NULL) {
/*
* Make sure we don't mess with server sockets since they will never
* be readable or writable at the Tcl level. This keeps Tcl scripts
* from interfering with the -accept behavior (bug #3394732).
*/
return;
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* Async sockets use a FileHandler internally while connecting, so we
* need to cache this request until the connection has succeeded.
*/
statePtr->filehandlers = mask;
} else if (mask) {
/*
* Whether it is a bug or feature or otherwise, it is a fact of life
* that on at least some Linux kernels select() fails to report that a
* socket file descriptor is writable when the other end of the socket
* is closed. This is in contrast to the guarantees Tcl makes that
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
socklen_t optlen;
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
int ret = -1, error = EHOSTUNREACH;
int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
static const int reuseaddr = 1;
if (async_callback) {
| | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 |
socklen_t optlen;
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
int ret = -1, error = EHOSTUNREACH;
int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
static const int reuseaddr = 1;
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
statePtr->addr = statePtr->addr->ai_next) {
for (statePtr->myaddr = statePtr->myaddrlist;
statePtr->myaddr != NULL;
statePtr->myaddr = statePtr->myaddr->ai_next) {
/*
* No need to try combinations of local and remote addresses of
* different families.
*/
if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
continue;
}
/*
* Close the socket if it is still open from the last unsuccessful
* iteration.
*/
if (statePtr->fds.fd >= 0) {
close(statePtr->fds.fd);
statePtr->fds.fd = -1;
errno = 0;
}
statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM,
0);
if (statePtr->fds.fd < 0) {
continue;
}
/*
* Set the close-on-exec flag so that the socket will not get
* inherited by child processes.
*/
fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC);
/*
* Set kernel space buffering
*/
TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE);
if (async) {
ret = TclUnixSetBlockingMode(statePtr->fds.fd,
TCL_MODE_NONBLOCKING);
if (ret < 0) {
continue;
}
}
/*
* Must reset the error variable here, before we use it for the
* first time in this iteration.
*/
error = 0;
(void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR,
(char *) &reuseaddr, sizeof(reuseaddr));
ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr,
statePtr->myaddr->ai_addrlen);
if (ret < 0) {
error = errno;
continue;
}
/*
* Attempt to connect. The connect may fail at present with an
* EINPROGRESS but at a later time it will complete. The caller
* will set up a file handler on the socket if she is interested
* in being informed when the connect completes.
*/
ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr,
statePtr->addr->ai_addrlen);
if (ret < 0) {
error = errno;
}
if (ret < 0 && errno == EINPROGRESS) {
Tcl_CreateFileHandler(statePtr->fds.fd,
TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback,
statePtr);
errno = EWOULDBLOCK;
SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
return TCL_OK;
reenter:
CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING);
Tcl_DeleteFileHandler(statePtr->fds.fd);
/*
* Read the error state from the socket to see if the async
* connection has succeeded or failed. As this clears the
* error condition, we cache the status in the socket state
* struct for later retrieval by [fconfigure -error].
*/
optlen = sizeof(int);
getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR,
(char *) &error, &optlen);
errno = error;
}
if (error == 0) {
goto out;
}
}
}
out:
statePtr->connectError = error;
CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
if (async_callback) {
/*
* An asynchonous connection has finally succeeded or failed.
*/
TcpWatchProc(statePtr, statePtr->filehandlers);
TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking);
if (error != 0) {
SET_BITS(statePtr->flags, TCP_ASYNC_FAILED);
}
/*
* We need to forward the writable event that brought us here, because
* upon reading of getsockopt(SO_ERROR), at least some OSes clear the
* writable state from the socket, and so a subsequent select() on
* behalf of a script level [fileevent] would not fire. It doesn't
* hurt that this is also called in the successful case and will save
* the event mechanism one roundtrip through select().
*/
if (statePtr->cachedBlocking == TCL_MODE_NONBLOCKING) {
Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE);
}
}
if (error != 0) {
/*
* Failure for either a synchronous connection, or an async one that
* failed before it could enter background mode, e.g. because an
* invalid -myaddr was given.
*/
if (interp != NULL) {
errno = error;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1508 1509 1510 1511 1512 1513 1514 |
char channelName[SOCK_CHAN_LENGTH];
/*
* Do the name lookups for the local and remote addresses.
*/
if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
| | | | | | | | | | | | | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 |
char channelName[SOCK_CHAN_LENGTH];
/*
* Do the name lookups for the local and remote addresses.
*/
if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
|| !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
&errorMsg)) {
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", errorMsg));
}
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
statePtr->cachedBlocking = TCL_MODE_BLOCKING;
statePtr->addrlist = addrlist;
statePtr->myaddrlist = myaddrlist;
statePtr->fds.fd = -1;
/*
* Create a new client socket and wrap it in a channel.
*/
if (TcpConnect(interp, statePtr) != TCL_OK) {
TcpCloseProc(statePtr, NULL);
return NULL;
}
snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, TCL_READABLE | TCL_WRITABLE);
if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_CloseEx(NULL, statePtr->channel, 0);
return NULL;
}
return statePtr->channel;
}
|
| ︙ | ︙ | |||
1574 1575 1576 1577 1578 1579 1580 |
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
| | | 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 |
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
TCL_READABLE | TCL_WRITABLE);
}
/*
*----------------------------------------------------------------------
*
* TclpMakeTcpClientChannelMode --
*
|
| ︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 |
*/
int retry = 0;
#define MAXRETRY 10
repeat:
if (retry > 0) {
| | | | | | | | | | | | | | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 |
*/
int retry = 0;
#define MAXRETRY 10
repeat:
if (retry > 0) {
if (statePtr != NULL) {
TcpCloseProc(statePtr, NULL);
statePtr = NULL;
}
if (addrlist != NULL) {
freeaddrinfo(addrlist);
addrlist = NULL;
}
if (retry >= MAXRETRY) {
goto error;
}
}
retry++;
chosenport = 0;
if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
errorMsg = "invalid port number";
goto error;
}
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
&errorMsg)) {
my_errno = errno;
goto error;
}
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
addrPtr->ai_protocol);
if (sock == -1) {
if (howfar < SOCKET) {
howfar = SOCKET;
my_errno = errno;
}
continue;
}
|
| ︙ | ︙ | |||
1757 1758 1759 1760 1761 1762 1763 | #else optvalue = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &optvalue, sizeof(optvalue)); #endif } | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 |
#else
optvalue = 1;
(void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT,
(char *) &optvalue, sizeof(optvalue));
#endif
}
/*
* Make sure we use the same port number when opening two server
* sockets for IPv4 and IPv6 on a random port.
*
* As sockaddr_in6 uses the same offset and size for the port member
* as sockaddr_in, we can handle both through the IPv4 API.
*/
if (port == 0 && chosenport != 0) {
((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
htons(chosenport);
}
#ifdef IPV6_V6ONLY
/*
* Missing on: Solaris 2.8
*/
if (addrPtr->ai_family == AF_INET6) {
int v6only = 1;
(void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY,
&v6only, sizeof(v6only));
}
#endif /* IPV6_V6ONLY */
status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
if (status == -1) {
if (howfar < BIND) {
howfar = BIND;
my_errno = errno;
}
close(sock);
sock = -1;
if (port == 0 && errno == EADDRINUSE) {
goto repeat;
}
continue;
}
if (port == 0 && chosenport == 0) {
address sockname;
socklen_t namelen = sizeof(sockname);
/*
* Synchronize port numbers when binding to port 0 of multiple
* addresses.
*/
if (getsockname(sock, &sockname.sa, &namelen) >= 0) {
chosenport = ntohs(sockname.sa4.sin_port);
}
}
if (backlog < 0) {
backlog = SOMAXCONN;
}
status = listen(sock, backlog);
if (status < 0) {
if (howfar < LISTEN) {
howfar = LISTEN;
my_errno = errno;
}
close(sock);
sock = -1;
if (port == 0 && errno == EADDRINUSE) {
goto repeat;
}
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));
newfds = &statePtr->fds;
} else {
newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList));
memset(newfds, (int) 0, sizeof(TcpFdList));
fds->next = newfds;
}
newfds->fd = sock;
newfds->statePtr = statePtr;
fds = newfds;
/*
* Set up the callback mechanism for accepting connections from new
* clients.
*/
Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds);
}
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
return statePtr->channel;
}
if (interp != NULL) {
Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE);
if (errorMsg == NULL) {
errno = my_errno;
Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE);
} else {
Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE);
}
Tcl_SetObjResult(interp, errorObj);
}
if (sock != -1) {
close(sock);
}
return NULL;
}
|
| ︙ | ︙ | |||
1935 1936 1937 1938 1939 1940 1941 |
newSockState, TCL_READABLE | TCL_WRITABLE);
Tcl_SetChannelOption(NULL, newSockState->channel, "-translation",
"auto crlf");
if (fds->statePtr->acceptProc != NULL) {
getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port),
| | | | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
newSockState, TCL_READABLE | TCL_WRITABLE);
Tcl_SetChannelOption(NULL, newSockState->channel, "-translation",
"auto crlf");
if (fds->statePtr->acceptProc != NULL) {
getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
fds->statePtr->acceptProc(fds->statePtr->acceptProcData,
newSockState->channel, host, atoi(port));
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
Changes to unix/tclUnixTest.c.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | static Tcl_ObjCmdProc TestchmodCmd; static Tcl_ObjCmdProc TestfilehandlerCmd; static Tcl_ObjCmdProc TestfilewaitCmd; static Tcl_ObjCmdProc TestfindexecutableCmd; static Tcl_ObjCmdProc TestforkCmd; static Tcl_ObjCmdProc TestgotsigCmd; static Tcl_FileProc TestFileHandlerProc; | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | static Tcl_ObjCmdProc TestchmodCmd; static Tcl_ObjCmdProc TestfilehandlerCmd; static Tcl_ObjCmdProc TestfilewaitCmd; static Tcl_ObjCmdProc TestfindexecutableCmd; static Tcl_ObjCmdProc TestforkCmd; static Tcl_ObjCmdProc TestgotsigCmd; static Tcl_FileProc TestFileHandlerProc; static void AlarmHandler(int signum); /* *---------------------------------------------------------------------- * * TclplatformtestInit -- * * Defines commands that test platform specific functionality for Unix |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
Tcl_CreateObjCommand(interp, "testfilehandler", TestfilehandlerCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilewait", TestfilewaitCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindexecutable", TestfindexecutableCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfork", TestforkCmd,
| | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
Tcl_CreateObjCommand(interp, "testfilehandler", TestfilehandlerCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilewait", TestfilewaitCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindexecutable", TestfindexecutableCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfork", TestforkCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testalarm", TestalarmCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgotsig", TestgotsigCmd,
NULL, NULL);
return TCL_OK;
}
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
testPipes[i].readFile = NULL;
}
initialized = 1;
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ...");
| | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
testPipes[i].readFile = NULL;
}
initialized = 1;
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ...");
return TCL_ERROR;
}
pipePtr = NULL;
if (objc >= 3) {
if (Tcl_GetIntFromObj(interp, objv[2], &i) != TCL_OK) {
return TCL_ERROR;
}
if (i >= MAX_PIPES) {
Tcl_AppendResult(interp, "bad index ", objv[2], (char *)NULL);
return TCL_ERROR;
}
pipePtr = &testPipes[i];
}
if (strcmp(Tcl_GetString(objv[1]), "close") == 0) {
for (i = 0; i < MAX_PIPES; i++) {
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 |
char buf[TCL_INTEGER_SPACE * 2];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
snprintf(buf, sizeof(buf), "%d %d", pipePtr->readCount, pipePtr->writeCount);
| | | | | | | | | | | | 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 |
char buf[TCL_INTEGER_SPACE * 2];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
snprintf(buf, sizeof(buf), "%d %d", pipePtr->readCount, pipePtr->writeCount);
Tcl_AppendResult(interp, buf, (char *)NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "index readMode writeMode");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) {
Tcl_AppendResult(interp, "couldn't open pipe: ",
Tcl_PosixError(interp), (char *)NULL);
return TCL_ERROR;
}
#ifdef O_NONBLOCK
fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
#else
Tcl_AppendResult(interp, "cannot make pipes non-blocking",
(char *)NULL);
return TCL_ERROR;
#endif
}
pipePtr->readCount = 0;
pipePtr->writeCount = 0;
if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
TestFileHandlerProc, pipePtr);
} else if (strcmp(Tcl_GetString(objv[3]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
} else if (strcmp(Tcl_GetString(objv[3]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
TestFileHandlerProc, pipePtr);
} else {
Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[3]), "\"", (char *)NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[4]), "writable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
TestFileHandlerProc, pipePtr);
} else if (strcmp(Tcl_GetString(objv[4]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
} else if (strcmp(Tcl_GetString(objv[4]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
TestFileHandlerProc, pipePtr);
} else {
Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[4]), "\"", (char *)NULL);
return TCL_ERROR;
}
} else if (strcmp(Tcl_GetString(objv[1]), "empty") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
/* Empty loop body. */
}
} else if (strcmp(Tcl_GetString(objv[1]), "fill") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'a', 4000);
while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
/* Empty loop body. */
}
} else if (strcmp(Tcl_GetString(objv[1]), "fillpartial") == 0) {
char buf[TCL_INTEGER_SPACE];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'b', 10);
TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
Tcl_AppendResult(interp, buf, (char *)NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "oneevent") == 0) {
Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
} else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "index readable|writable timeout");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
Tcl_AppendResult(interp, "pipe ", Tcl_GetString(objv[2]), " doesn't exist", (char *)NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
mask = TCL_READABLE;
file = pipePtr->readFile;
} else {
mask = TCL_WRITABLE;
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 |
Tcl_AppendElement(interp, "writable");
}
} else if (strcmp(Tcl_GetString(objv[1]), "windowevent") == 0) {
Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be close, clear, counts, create, empty, fill, "
| | | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 |
Tcl_AppendElement(interp, "writable");
}
} else if (strcmp(Tcl_GetString(objv[1]), "windowevent") == 0) {
Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be close, clear, counts, create, empty, fill, "
"fillpartial, oneevent, wait, or windowevent", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
TestFileHandlerProc(
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
mask = TCL_READABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "writable") == 0){
mask = TCL_WRITABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "both") == 0){
mask = TCL_WRITABLE|TCL_READABLE;
} else {
Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]),
| | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
mask = TCL_READABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "writable") == 0){
mask = TCL_WRITABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "both") == 0){
mask = TCL_WRITABLE|TCL_READABLE;
} else {
Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]),
"\": must be readable, writable, or both", (char *)NULL);
return TCL_ERROR;
}
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
(void **) &data) != TCL_OK) {
Tcl_AppendResult(interp, "couldn't get channel file", (char *)NULL);
return TCL_ERROR;
}
fd = PTR2INT(data);
if (Tcl_GetIntFromObj(interp, objv[3], &timeout) != TCL_OK) {
return TCL_ERROR;
}
result = TclUnixWaitForFile(fd, mask, timeout);
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
if (objc != 1) {
| | | | | | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
pid = fork();
if (pid == -1) {
Tcl_AppendResult(interp,
"Cannot fork", (char *)NULL);
return TCL_ERROR;
}
/* Only needed when pthread_atfork is not present,
* should not hurt otherwise. */
if (pid==0) {
Tcl_InitNotifier();
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid));
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
/*
* Setup the signal handling that automatically retries any interrupted
* I/O system calls.
*/
action.sa_handler = AlarmHandler;
| | | | | | | | 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 |
/*
* Setup the signal handling that automatically retries any interrupted
* I/O system calls.
*/
action.sa_handler = AlarmHandler;
memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
action.sa_flags = SA_RESTART;
if (sigaction(SIGALRM, &action, NULL) < 0) {
Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), (char *)NULL);
return TCL_ERROR;
}
(void) alarm(sec);
return TCL_OK;
#else
Tcl_AppendResult(interp,
"warning: sigaction SA_RESTART not support on this platform",
(char *)NULL);
return TCL_ERROR;
#endif
}
/*
*----------------------------------------------------------------------
*
* AlarmHandler --
*
* Signal handler for the alarm command.
*
* Results:
* None.
*
* Side effects:
* Calls the Tcl Async handler.
*
*----------------------------------------------------------------------
*/
static void
AlarmHandler(
TCL_UNUSED(int) /*signum*/)
{
gotsig = "1";
}
/*
*----------------------------------------------------------------------
*
* TestgotsigCmd --
*
* Verify the signal was handled after the testalarm command.
*
* Results:
* None.
*
* Side Effects:
* Resets the value of gotsig back to '0'.
*
*----------------------------------------------------------------------
*/
static int
TestgotsigCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *))
{
Tcl_AppendResult(interp, gotsig, (char *)NULL);
gotsig = "0";
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (chmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
| | | 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 |
translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (chmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
(char *)NULL);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
}
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to unix/tclUnixThrd.c.
| ︙ | ︙ | |||
330 331 332 333 334 335 336 | * * Side effects: * This procedure terminates the current thread. * *---------------------------------------------------------------------- */ | | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
*
* Side effects:
* This procedure terminates the current thread.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
TclpThreadExit(
int status)
{
#if TCL_THREADS
pthread_exit(INT2PTR(status));
#else /* TCL_THREADS */
exit(status);
|
| ︙ | ︙ |
Changes to unix/tclUnixTime.c.
| ︙ | ︙ | |||
242 243 244 245 246 247 248 | * TclpWideClickInMicrosec -- * * This procedure return scale to convert click values from the * TclpGetWideClicks native resolution to microsecond resolution * and back. * * Results: | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | * TclpWideClickInMicrosec -- * * This procedure return scale to convert click values from the * TclpGetWideClicks native resolution to microsecond resolution * and back. * * Results: * 1 click in microseconds as double. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ |
Changes to unix/tclXtNotify.c.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | static void SetTimer(const Tcl_Time * timePtr); static int WaitForEvent(const Tcl_Time * timePtr); /* * Functions defined in this file for use by users of the Xt Notifier: */ | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | static void SetTimer(const Tcl_Time * timePtr); static int WaitForEvent(const Tcl_Time * timePtr); /* * Functions defined in this file for use by users of the Xt Notifier: */ MODULE_SCOPE void InitNotifier(void); MODULE_SCOPE XtAppContext TclSetAppContext(XtAppContext ctx); /* *---------------------------------------------------------------------- * * TclSetAppContext -- * |
| ︙ | ︙ |
Changes to unix/tclXtTest.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | static Tcl_ObjCmdProc TesteventloopCmd; /* * Functions defined in tclXtNotify.c for use by users of the Xt Notifier: */ | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | static Tcl_ObjCmdProc TesteventloopCmd; /* * Functions defined in tclXtNotify.c for use by users of the Xt Notifier: */ extern void InitNotifier(void); extern XtAppContext TclSetAppContext(XtAppContext ctx); /* *---------------------------------------------------------------------- * * Tclxttest_Init -- * |
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
while (!done) {
XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
while (!done) {
XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be done or wait", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to win/Makefile.in.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 | bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ runstatedir = @runstatedir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = # Directory from which applications will reference the library of Tcl scripts | > > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ runstatedir = @runstatedir@ mandir = @mandir@ # Configure arguments PKG_CFG_ARGS = @PKG_CFG_ARGS@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = # Directory from which applications will reference the library of Tcl scripts |
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: | | | | | > > | 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 | # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0 # To compile without backward compatibility and deprecated code uncomment the # following NO_DEPRECATED_FLAGS = #NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # To enable compilation debugging reverse the comment characters on one of the # following lines. COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. TOP_DIR = $(shell cd @srcdir@/..; pwd -W 2>/dev/null || pwd -P) BUILD_DIR = @builddir@ GENERIC_DIR = $(TOP_DIR)/generic WIN_DIR = $(TOP_DIR)/win COMPAT_DIR = $(TOP_DIR)/compat PKGS_DIR = $(TOP_DIR)/pkgs TOOL_DIR = $(TOP_DIR)/tools ZLIB_DIR = $(COMPAT_DIR)/zlib MINIZIP_DIR = $(ZLIB_DIR)/contrib/minizip TOMMATH_DIR = $(TOP_DIR)/libtommath # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ libdir_native = $(shell $(CYGPATH) '$(libdir)') bindir_native = $(shell $(CYGPATH) '$(bindir)') includedir_native = $(shell $(CYGPATH) '$(includedir)') mandir_native = $(shell $(CYGPATH) '$(mandir)') TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)') GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') TOOL_DIR_NATIVE = $(shell $(CYGPATH) '$(TOOL_DIR)') SCRIPT_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(SCRIPT_INSTALL_DIR)') INCLUDE_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(INCLUDE_INSTALL_DIR)') MAN_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(MAN_INSTALL_DIR)') ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W 2>/dev/null || pwd -P) ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') MINIZIP_DIR_NATIVE = $(shell $(CYGPATH) '$(MINIZIP_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') |
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX}
REG_DLL_FILE8 = tclregistry$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX}
TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
| | | | | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX}
REG_DLL_FILE8 = tclregistry$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX}
TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\
package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}]
TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\
$(TEST_LOAD_PRMS)
ZLIB_DLL_FILE = zlib1.dll
TOMMATH_DLL_FILE = libtommath.dll
SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
WINE = @WINE@
CAT32 = cat32$(EXEEXT)
# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 216 217 218 219 | RMDIR = rm -rf MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp LN = ln ### # Tip 430 - ZipFS Modifications ### TCL_ZIP_FILE = @TCL_ZIP_FILE@ TCL_VFS_PATH = libtcl.vfs/tcl_library | > | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | RMDIR = rm -rf MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp LN = ln GDB = gdb ### # Tip 430 - ZipFS Modifications ### TCL_ZIP_FILE = @TCL_ZIP_FILE@ TCL_VFS_PATH = libtcl.vfs/tcl_library |
| ︙ | ︙ | |||
236 237 238 239 240 241 242 | ifeq ($(ZIPFS_BUILD), 0) LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)') endif # Minizip MINIZIP_OBJS = \ | | | | | | | | | | | | | | | | | 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 |
ifeq ($(ZIPFS_BUILD), 0)
LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P)
LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)')
endif
# Minizip
MINIZIP_OBJS = \
adler32.$(HOST_OBJEXT) \
compress.$(HOST_OBJEXT) \
crc32.$(HOST_OBJEXT) \
deflate.$(HOST_OBJEXT) \
infback.$(HOST_OBJEXT) \
inffast.$(HOST_OBJEXT) \
inflate.$(HOST_OBJEXT) \
inftrees.$(HOST_OBJEXT) \
ioapi.$(HOST_OBJEXT) \
iowin32.$(HOST_OBJEXT) \
trees.$(HOST_OBJEXT) \
uncompr.$(HOST_OBJEXT) \
zip.$(HOST_OBJEXT) \
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
CC_SWITCHES = -I"${BUILD_DIR}" -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
|
| ︙ | ︙ | |||
288 289 290 291 292 293 294 295 296 297 298 299 300 301 | tclArithSeries.$(OBJEXT) \ tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ tclCkalloc.$(OBJEXT) \ tclClock.$(OBJEXT) \ tclCmdAH.$(OBJEXT) \ tclCmdIL.$(OBJEXT) \ tclCmdMZ.$(OBJEXT) \ tclCompCmds.$(OBJEXT) \ tclCompCmdsGR.$(OBJEXT) \ tclCompCmdsSZ.$(OBJEXT) \ tclCompExpr.$(OBJEXT) \ | > | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | tclArithSeries.$(OBJEXT) \ tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ tclCkalloc.$(OBJEXT) \ tclClock.$(OBJEXT) \ tclClockFmt.$(OBJEXT) \ tclCmdAH.$(OBJEXT) \ tclCmdIL.$(OBJEXT) \ tclCmdMZ.$(OBJEXT) \ tclCompCmds.$(OBJEXT) \ tclCompCmdsGR.$(OBJEXT) \ tclCompCmdsSZ.$(OBJEXT) \ tclCompExpr.$(OBJEXT) \ |
| ︙ | ︙ | |||
310 311 312 313 314 315 316 317 318 319 320 321 322 323 | tclEvent.$(OBJEXT) \ tclExecute.$(OBJEXT) \ tclFCmd.$(OBJEXT) \ tclFileName.$(OBJEXT) \ tclGet.$(OBJEXT) \ tclHash.$(OBJEXT) \ tclHistory.$(OBJEXT) \ tclIndexObj.$(OBJEXT) \ tclInterp.$(OBJEXT) \ tclIO.$(OBJEXT) \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ tclIORTrans.$(OBJEXT) \ | > | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 | tclEvent.$(OBJEXT) \ tclExecute.$(OBJEXT) \ tclFCmd.$(OBJEXT) \ tclFileName.$(OBJEXT) \ tclGet.$(OBJEXT) \ tclHash.$(OBJEXT) \ tclHistory.$(OBJEXT) \ tclIcu.$(OBJEXT) \ tclIndexObj.$(OBJEXT) \ tclInterp.$(OBJEXT) \ tclIO.$(OBJEXT) \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ tclIORTrans.$(OBJEXT) \ |
| ︙ | ︙ | |||
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 | tclNotify.$(OBJEXT) \ tclOO.$(OBJEXT) \ tclOOBasic.$(OBJEXT) \ tclOOCall.$(OBJEXT) \ tclOODefineCmds.$(OBJEXT) \ tclOOInfo.$(OBJEXT) \ tclOOMethod.$(OBJEXT) \ tclOOStubInit.$(OBJEXT) \ tclObj.$(OBJEXT) \ tclOptimize.$(OBJEXT) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ tclPathObj.$(OBJEXT) \ tclPipe.$(OBJEXT) \ tclPkg.$(OBJEXT) \ tclPkgConfig.$(OBJEXT) \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ tclThreadStorage.$(OBJEXT) \ tclTimer.$(OBJEXT) \ | > > | 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 | tclNotify.$(OBJEXT) \ tclOO.$(OBJEXT) \ tclOOBasic.$(OBJEXT) \ tclOOCall.$(OBJEXT) \ tclOODefineCmds.$(OBJEXT) \ tclOOInfo.$(OBJEXT) \ tclOOMethod.$(OBJEXT) \ tclOOProp.$(OBJEXT) \ tclOOStubInit.$(OBJEXT) \ tclObj.$(OBJEXT) \ tclOptimize.$(OBJEXT) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ tclPathObj.$(OBJEXT) \ tclPipe.$(OBJEXT) \ tclPkg.$(OBJEXT) \ tclPkgConfig.$(OBJEXT) \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ tclStrIdxTree.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ tclThreadStorage.$(OBJEXT) \ tclTimer.$(OBJEXT) \ |
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
bn_mp_cnt_lsb.${OBJEXT} \
bn_mp_copy.${OBJEXT} \
bn_mp_count_bits.${OBJEXT} \
bn_mp_div.${OBJEXT} \
bn_mp_div_d.${OBJEXT} \
bn_mp_div_2.${OBJEXT} \
bn_mp_div_2d.${OBJEXT} \
| | | | 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
bn_mp_cnt_lsb.${OBJEXT} \
bn_mp_copy.${OBJEXT} \
bn_mp_count_bits.${OBJEXT} \
bn_mp_div.${OBJEXT} \
bn_mp_div_d.${OBJEXT} \
bn_mp_div_2.${OBJEXT} \
bn_mp_div_2d.${OBJEXT} \
bn_s_mp_div_3.${OBJEXT} \
bn_mp_exch.${OBJEXT} \
bn_mp_expt_n.${OBJEXT} \
bn_mp_get_mag_u64.${OBJEXT} \
bn_mp_grow.${OBJEXT} \
bn_mp_init.${OBJEXT} \
bn_mp_init_copy.${OBJEXT} \
bn_mp_init_i64.${OBJEXT} \
bn_mp_init_multi.${OBJEXT} \
bn_mp_init_set.${OBJEXT} \
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 |
${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE}
@rm -rf ${TCL_VFS_ROOT}
@mkdir -p ${TCL_VFS_PATH}
@echo "creating ${TCL_VFS_PATH} (prepare compression)"
@( \
$(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
$(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
| | | < < | < < > > > > > | 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 |
${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE}
@rm -rf ${TCL_VFS_ROOT}
@mkdir -p ${TCL_VFS_PATH}
@echo "creating ${TCL_VFS_PATH} (prepare compression)"
@( \
$(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
$(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
rm -rf ${TCL_VFS_PATH}/dde; \
rm -rf ${TCL_VFS_PATH}/registry; \
)
(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \
(echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \
cd ${TCL_VFS_ROOT} && \
$$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \
echo "${TCL_ZIP_FILE} successful created with $$zip" && \
cd ..)
$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) ${TCL_ZIP_FILE}
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest $(TCLSH).manifest
@VC_MANIFEST_EMBED_EXE@
@if test "${ZIPFS_BUILD}" = "2" ; then \
cat ${TCL_ZIP_FILE} >> ${TCLSH}; \
fi
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
$(CAT32): cat32.$(OBJEXT)
$(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE)
# The following targets are configured by autoconf to generate either a shared
# library or static library
${TCL_STUB_LIB_FILE}: ${STUB_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_STUB_LIB_FILE}
@MAKE_STUB_LIB@ ${STUB_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
${TCL_DLL_FILE}: ${TCL_LIB_FILE} ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ ${TCL_ZIP_FILE}
@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TCL_DLL_FILE}.manifest
@VC_MANIFEST_EMBED_DLL@
@if test "${ZIPFS_BUILD}" = "1" ; then \
cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
fi
ifeq (,$(findstring --disable-shared,$(PKG_CFG_ARGS)))
${TCL_LIB_FILE}:
@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
else
${TCL_LIB_FILE}: ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
endif
${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS}
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest
${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
|
| ︙ | ︙ | |||
607 608 609 610 611 612 613 |
$(COPY) tclsh.exe.manifest ${REG_DLL_FILE8}.manifest
${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest
| | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
$(COPY) tclsh.exe.manifest ${REG_DLL_FILE8}.manifest
${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest
${TEST_EXE_FILE}: @LIBRARIES@ ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
@$(RM) ${TEST_EXE_FILE}
$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest
# use prebuilt zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \
$(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \
|
| ︙ | ︙ | |||
920 921 922 923 924 925 926 | done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package cookiejar 0.2" @for j in $(ROOT_DIR)/library/cookiejar/*.tcl \ | | | | | | | 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 | done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package cookiejar 0.2" @for j in $(ROOT_DIR)/library/cookiejar/*.tcl \ $(ROOT_DIR)/library/cookiejar/*.gz; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; @echo "Installing package http 2.10.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/9.0/http-2.10.0.tm"; @echo "Installing package opt 0.4.7"; @for j in $(ROOT_DIR)/library/opt/*.tcl; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm"; @echo "Installing package tcltest 2.5.9 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.9.tm"; @echo "Installing package platform 1.0.19 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/9.0/platform-1.0.19.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm"; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ |
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 | @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ $(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ | | | > > > > > > > > > | 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 |
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
$(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
# `make shell SCRIPT=foo.tcl`
shell: binaries
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
$(WINE) ./$(TCLSH) $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: binaries
@echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run
$(GDB) ./$(TCLSH) --command=gdb.run
rm gdb.run
shquotequote = $(subst ',\",$(subst ",\",$(1)))
gdb-test: tcltest
@printf '%s ' 'set env TCL_LIBRARY=$(LIBRARY_DIR)' > gdb.run
@printf '\n' >>gdb.run
@printf '%s ' set args $(ROOT_DIR_NATIVE)/tests/all.tcl \
$(call shquotequote,$(TESTFLAGS)) -singleproc 1 >> gdb.run
$(GDB) ${TEST_EXE_FILE} --command=gdb.run
rm gdb.run
depend:
Makefile: $(SRC_DIR)/Makefile.in
./config.status
|
| ︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 | $(RM) Makefile config.status config.cache config.log tclConfig.sh \ config.status.lineno tclsh.exe.manifest tclUuid.h # # Bundled package targets # | < | | | | | | | | | > > > > > | | > > > > > | 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 |
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
config.status.lineno tclsh.exe.manifest tclUuid.h
#
# Bundled package targets
#
PKG_DIR = ./pkgs
packages:
@builddir=`$(CYGPATH) $$(pwd -P)`; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
if [ -x $$i/configure ] ; then \
pkg=`basename $$i`; \
mkdir -p $(PKG_DIR)/$$pkg; \
if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \
( cd $(PKG_DIR)/$$pkg; \
echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \
$$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared; ) \
fi ; \
echo "Building package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \
fi; \
fi; \
done; \
cd $$builddir
install-packages: packages
@builddir=`pwd -P`; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
echo "Installing package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE) install "DESTDIR=$(INSTALL_ROOT)"; ) \
fi; \
fi; \
done; \
cd $$builddir
test-packages: tcltest packages
@builddir=`pwd -P`; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
echo "Testing package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/${TCLSH}"; ) \
fi; \
fi; \
done; \
cd $$builddir
clean-packages:
@builddir=`pwd -P`; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \
fi; \
fi; \
done; \
cd $$builddir
distclean-packages:
@builddir=`pwd -P`; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ]; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \
fi; \
cd $$builddir; \
rm -rf $(PKG_DIR)/$$pkg; \
fi; \
done; \
rm -rf $(PKG_DIR)
#
# Regenerate the stubs files.
#
$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls
@echo "Warning: tclStubInit.c may be out of date."
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
$(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
@echo "Warning: tclOOScript.h may be out of date."
@echo "Developers may want to run \"make genscript\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
genstubs:
$(TCL_EXE) "$(TOOL_DIR_NATIVE)/genStubs.tcl" \
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)/tcl.decls" \
"$(GENERIC_DIR_NATIVE)/tclInt.decls" \
"$(GENERIC_DIR_NATIVE)/tclTomMath.decls"
$(TCL_EXE) "$(TOOL_DIR_NATIVE)/genStubs.tcl" \
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)/tclOO.decls"
genscript:
$(TCL_EXE) "$(TOOL_DIR_NATIVE)/makeHeader.tcl" \
"$(TOOL_DIR_NATIVE)/tclOOScript.tcl" \
"$(GENERIC_DIR_NATIVE)/tclOOScript.h"
#
# 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.* &
# tk8.* up two directories from the TOOL_DIR.
#
|
| ︙ | ︙ | |||
1167 1168 1169 1170 1171 1172 1173 | # .PHONY: all tcltest binaries libraries doc gendate gentommath_h install .PHONY: install-binaries install-libraries install-tzdata install-msgs .PHONY: install-doc install-private-headers test test-tcl runtest shell .PHONY: gdb depend cleanhelp clean distclean packages install-packages .PHONY: test-packages clean-packages distclean-packages genstubs html | | | 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 | # .PHONY: all tcltest binaries libraries doc gendate gentommath_h install .PHONY: install-binaries install-libraries install-tzdata install-msgs .PHONY: install-doc install-private-headers test test-tcl runtest shell .PHONY: gdb depend cleanhelp clean distclean packages install-packages .PHONY: test-packages clean-packages distclean-packages genstubs html .PHONY: html-tcl html-tk genscript .PHONY: tclzipfile # DO NOT DELETE THIS LINE -- make depend depends on it. |
Changes to win/configure.
| ︙ | ︙ | |||
2407 2408 2409 2410 2411 2412 2413 | # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 | | | 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 | # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
| ︙ | ︙ | |||
4185 4186 4187 4188 4189 4190 4191 |
CYGPATH=echo
fi
conftest=
cyg_conftest=
fi
if test "$CYGPATH" = "echo"; then
| | | | 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 |
CYGPATH=echo
fi
conftest=
cyg_conftest=
fi
if test "$CYGPATH" = "echo"; then
DEPARG='"$<"'
else
DEPARG='"$(shell $(CYGPATH) $<)"'
fi
# set various compiler flags depending on whether we are using gcc or cl
if test "${GCC}" = "yes" ; then
extra_cflags="-pipe"
extra_ldflags="-pipe -static-libgcc"
|
| ︙ | ︙ | |||
4232 4233 4234 4235 4236 4237 4238 |
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_win32" >&5
printf "%s\n" "$ac_cv_win32" >&6; }
if test "$ac_cv_win32" != "yes"; then
as_fn_error $? "${CC} cannot produce win32 executables." "$LINENO" 5
fi
| | | 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 |
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_win32" >&5
printf "%s\n" "$ac_cv_win32" >&6; }
if test "$ac_cv_win32" != "yes"; then
as_fn_error $? "${CC} cannot produce win32 executables." "$LINENO" 5
fi
if test "$do64bit" != "arm64" -a "$do64bit" != "aarch64"; then
extra_cflags="$extra_cflags -DHAVE_CPUID=1"
fi
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working -municode linker flag" >&5
printf %s "checking for working -municode linker flag... " >&6; }
if test ${ac_cv_municode+y}
|
| ︙ | ︙ | |||
4431 4432 4433 4434 4435 4436 4437 |
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_enable_auto_image_base" >&5
printf "%s\n" "$ac_cv_enable_auto_image_base" >&6; }
CFLAGS=$hold_cflags
| | | 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 |
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_enable_auto_image_base" >&5
printf "%s\n" "$ac_cv_enable_auto_image_base" >&6; }
CFLAGS=$hold_cflags
if test "$ac_cv_enable_auto_image_base" = "yes" ; then
extra_ldflags="$extra_ldflags -Wl,--enable-auto-image-base"
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking compiler flags" >&5
printf %s "checking compiler flags... " >&6; }
if test "${GCC}" = "yes" ; then
SHLIB_LD=""
|
| ︙ | ︙ | |||
4457 4458 4459 4460 4461 4462 4463 |
MAKE_STUB_LIB="\${STLIB_LD} \$@"
POST_MAKE_LIB="\${RANLIB} \$@"
MAKE_EXE="\${CC} -o \$@"
LIBPREFIX="lib"
if test "${SHARED_BUILD}" = "0" ; then
# static
| | | | | 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 |
MAKE_STUB_LIB="\${STLIB_LD} \$@"
POST_MAKE_LIB="\${RANLIB} \$@"
MAKE_EXE="\${CC} -o \$@"
LIBPREFIX="lib"
if test "${SHARED_BUILD}" = "0" ; then
# static
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
printf "%s\n" "using static flags" >&6; }
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
printf "%s\n" "using shared flags" >&6; }
# ad-hoc check to see if CC supports -shared.
if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
as_fn_error $? "${CC} does not support the -shared option.
You will need to upgrade to a newer version of the toolchain." "$LINENO" 5
fi
runtime=
# Add SHLIB_LD_LIBS to the Make rule, not here.
EXESUFFIX=".exe"
LIBRARIES="\${SHARED_LIBRARIES}"
|
| ︙ | ︙ | |||
4582 4583 4584 4585 4586 4587 4588 |
printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
fi
;;
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
| | | | 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 |
printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
fi
;;
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
printf "%s\n" "using static flags" >&6; }
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
printf "%s\n" "using shared flags" >&6; }
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
LIBRARIES="\${SHARED_LIBRARIES}"
EXESUFFIX=".exe"
case "x`echo \${VisualStudioVersion}`" in
x1[4-9]*)
|
| ︙ | ︙ | |||
4953 4954 4955 4956 4957 4958 4959 | if test "$do64bit" != "no" then : printf "%s\n" "#define MP_64BIT 1" >>confdefs.h | | | | | | | | | | | | | | | | > > > < < < | 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 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 |
if test "$do64bit" != "no"
then :
printf "%s\n" "#define MP_64BIT 1" >>confdefs.h
if test "$do64bit" = "arm64" -o "$do64bit" = "aarch64"
then :
if test "$GCC" = "yes"
then :
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a
zlib_lib_name=libz.dll.a
tommath_lib_name=libtommath.dll.a
else case e in #(
e)
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib
;;
esac
fi
else case e in #(
e)
if test "$GCC" = "yes"
then :
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a
zlib_lib_name=libz.dll.a
tommath_lib_name=libtommath.dll.a
else case e in #(
e)
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib
;;
esac
fi
;;
esac
fi
else case e in #(
e)
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win32/tommath.lib
;;
esac
fi
else case e in #(
e)
printf "%s\n" "#define TCL_WITH_INTERNAL_ZLIB 1" >>confdefs.h
ZLIB_OBJS=\${ZLIB_OBJS}
TOMMATH_OBJS=\${TOMMATH_OBJS}
;;
esac
fi
TCL_ZLIB_LIB_NAME=$zlib_lib_name
TCL_TOMMATH_LIB_NAME=$tommath_lib_name
ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "
#include <stdint.h>
|
| ︙ | ︙ | |||
5186 5187 5188 5189 5190 5191 5192 |
if test ${ac_cv_path_zip+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
| | | | | | | | | | | | | | | | | | | | | | | | 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 |
if test ${ac_cv_path_zip+y}
then :
printf %s "(cached) " >&6
else case e in #(
e)
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
;;
esac
fi
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
printf "%s\n" "$ZIP_PROG" >&6; }
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
printf "%s\n" "Found INFO Zip in environment" >&6; }
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH building minizip" >&5
printf "%s\n" "No zip found on PATH building minizip" >&6; }
fi
|
| ︙ | ︙ | |||
5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 |
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intrinsics" >&5
printf "%s\n" "$tcl_cv_intrinsics" >&6; }
if test "$tcl_cv_intrinsics" = "yes"; then
printf "%s\n" "#define HAVE_INTRIN_H 1" >>confdefs.h
fi
# See if the <wspiapi.h> header file is present
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for wspiapi.h" >&5
printf %s "checking for wspiapi.h... " >&6; }
if test ${tcl_cv_wspiapi_h+y}
then :
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 |
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intrinsics" >&5
printf "%s\n" "$tcl_cv_intrinsics" >&6; }
if test "$tcl_cv_intrinsics" = "yes"; then
printf "%s\n" "#define HAVE_INTRIN_H 1" >>confdefs.h
fi
# See if the compiler supports cpuid header.
if test "${GCC}" = "yes" ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cpuid-header support in compiler" >&5
printf %s "checking for cpuid-header support in compiler... " >&6; }
if test ${tcl_cv_cpuidhead+y}
then :
printf %s "(cached) " >&6
else case e in #(
e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 8))))
# include <cpuid.h>
#endif
int
main (void)
{
unsigned int regs;
__get_cpuid(0, ®s, ®s, ®s, ®s);
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_cpuidhead=yes
else case e in #(
e) tcl_cv_cpuidhead=no ;;
esac
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
;;
esac
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cpuidhead" >&5
printf "%s\n" "$tcl_cv_cpuidhead" >&6; }
if test "$tcl_cv_cpuidhead" = "yes"; then
printf "%s\n" "#define HAVE_CPUID_H 1" >>confdefs.h
fi
fi
# See if the <wspiapi.h> header file is present
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for wspiapi.h" >&5
printf %s "checking for wspiapi.h... " >&6; }
if test ${tcl_cv_wspiapi_h+y}
then :
|
| ︙ | ︙ | |||
5899 5900 5901 5902 5903 5904 5905 | # The statements below define the symbol TCL_PACKAGE_PATH, which # gives a list of directories that may contain packages. The list # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$prefix/lib" != "$libdir"; then | | | | 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 |
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix/lib" != "$libdir"; then
TCL_PACKAGE_PATH="${libdir};${prefix}\\lib"
else
TCL_PACKAGE_PATH="${prefix}\\lib"
fi
# The tclsh.exe.manifest requires these
# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs
# the release level, and must account for interim release versioning
case "$TCL_PATCH_LEVEL" in
*a*) TCL_RELEASE_LEVEL=0 ;;
|
| ︙ | ︙ |
Changes to win/configure.ac.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
| ︙ | ︙ | |||
125 126 127 128 129 130 131 |
tommath_lib_name=tommath.lib
AS_IF([test "$tcl_ok" = "yes"], [
AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
AC_SUBST(TOMMATH_DLL_FILE,[\${TOMMATH_DLL_FILE}])
AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
AS_IF([test "$do64bit" != "no"], [
AC_DEFINE(MP_64BIT, 1, [Using libtommath.dll in 64-bit mode])
| | | | | | | | | | | | | | | | > < | 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 |
tommath_lib_name=tommath.lib
AS_IF([test "$tcl_ok" = "yes"], [
AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
AC_SUBST(TOMMATH_DLL_FILE,[\${TOMMATH_DLL_FILE}])
AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
AS_IF([test "$do64bit" != "no"], [
AC_DEFINE(MP_64BIT, 1, [Using libtommath.dll in 64-bit mode])
AS_IF([test "$do64bit" = "arm64" -o "$do64bit" = "aarch64"], [
AS_IF([test "$GCC" = "yes"],[
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a])
zlib_lib_name=libz.dll.a
tommath_lib_name=libtommath.dll.a
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib])
])
], [
AS_IF([test "$GCC" = "yes"],[
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a])
zlib_lib_name=libz.dll.a
tommath_lib_name=libtommath.dll.a
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/tommath.lib])
])
])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win32/tommath.lib])
])
], [
AC_DEFINE(TCL_WITH_INTERNAL_ZLIB, 1, [Tcl with internal zlib])
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
])
AC_SUBST(TCL_ZLIB_LIB_NAME, $zlib_lib_name)
AC_SUBST(TCL_TOMMATH_LIB_NAME, $tommath_lib_name)
AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[
#include <stdint.h>
]])
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
FINDEX_SEARCH_OPS j;
]])],
[tcl_cv_findex_enums=yes],
[tcl_cv_findex_enums=no])
)
if test "$tcl_cv_findex_enums" = "no"; then
AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1,
| | | > > > > > > > > > > > > > > > > > > > > > > | | 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 |
FINDEX_SEARCH_OPS j;
]])],
[tcl_cv_findex_enums=yes],
[tcl_cv_findex_enums=no])
)
if test "$tcl_cv_findex_enums" = "no"; then
AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1,
[Defined when enums are missing from winbase.h])
fi
# See if the compiler supports intrinsics.
AC_CACHE_CHECK(for intrinsics support in compiler,
tcl_cv_intrinsics,
AC_LINK_IFELSE([AC_LANG_PROGRAM([[
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
#include <intrin.h>
]], [[
__cpuidex(0,0,0);
]])],
[tcl_cv_intrinsics=yes],
[tcl_cv_intrinsics=no])
)
if test "$tcl_cv_intrinsics" = "yes"; then
AC_DEFINE(HAVE_INTRIN_H, 1,
[Defined when the compilers supports intrinsics])
fi
# See if the compiler supports cpuid header.
if test "${GCC}" = "yes" ; then
AC_CACHE_CHECK(for cpuid-header support in compiler,
tcl_cv_cpuidhead,
AC_LINK_IFELSE([AC_LANG_PROGRAM([[
#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 8))))
# include <cpuid.h>
#endif
]], [[
unsigned int regs;
__get_cpuid(0, ®s, ®s, ®s, ®s);
]])],
[tcl_cv_cpuidhead=yes],
[tcl_cv_cpuidhead=no])
)
if test "$tcl_cv_cpuidhead" = "yes"; then
AC_DEFINE(HAVE_CPUID_H, 1,
[Defined when the compilers supports cpuid header])
fi
fi
# See if the <wspiapi.h> header file is present
AC_CACHE_CHECK(for wspiapi.h,
tcl_cv_wspiapi_h,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <wspiapi.h>
]], [[]])],
[tcl_cv_wspiapi_h=yes],
[tcl_cv_wspiapi_h=no])
)
if test "$tcl_cv_wspiapi_h" = "yes"; then
AC_DEFINE(HAVE_WSPIAPI_H, 1,
[Defined when wspiapi.h exists])
fi
# See if declarations like FINDEX_INFO_LEVELS are
# missing from winbase.h. This is known to be
# a problem with VC++ 5.2.
AC_CACHE_CHECK(for FINDEX_INFO_LEVELS in winbase.h,
|
| ︙ | ︙ | |||
285 286 287 288 289 290 291 |
FINDEX_SEARCH_OPS j;
]])],
[tcl_cv_findex_enums=yes],
[tcl_cv_findex_enums=no])
)
if test "$tcl_cv_findex_enums" = "no"; then
AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1,
| | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
FINDEX_SEARCH_OPS j;
]])],
[tcl_cv_findex_enums=yes],
[tcl_cv_findex_enums=no])
)
if test "$tcl_cv_findex_enums" = "no"; then
AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1,
[Defined when enums are missing from winbase.h])
fi
#--------------------------------------------------------------------
# Set the default compiler switches based on the --enable-symbols
# option. This macro depends on C flags, and should be called
# after SC_CONFIG_CFLAGS macro is called.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 | # The statements below define the symbol TCL_PACKAGE_PATH, which # gives a list of directories that may contain packages. The list # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$prefix/lib" != "$libdir"; then | | | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix/lib" != "$libdir"; then
TCL_PACKAGE_PATH="${libdir};${prefix}\\lib"
else
TCL_PACKAGE_PATH="${prefix}\\lib"
fi
# The tclsh.exe.manifest requires these
# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs
# the release level, and must account for interim release versioning
case "$TCL_PATCH_LEVEL" in
*a*) TCL_RELEASE_LEVEL=0 ;;
|
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | # # Basic macros and options usable on the commandline (see rules.vc for more info): # OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | # # Basic macros and options usable on the commandline (see rules.vc for more info): # OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # # noembed = Without this option, the Tcl core library scripts # are embedded into the executable if "static" is # specified in OPTS, or into the DLL otherwise. If # "noembed" is specified, the scripts are not embedded # but copied to the installation target (as in 8.6). # nomsvcrt = Affects the static option only to switch it from # using msvcrt(d) as the C runtime [by default] to # libcmt(d). This is useful for static embedding |
| ︙ | ︙ | |||
250 251 252 253 254 255 256 257 258 259 260 261 262 263 | $(TMP_DIR)\tclAlloc.obj \ $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ $(TMP_DIR)\tclBinary.obj \ $(TMP_DIR)\tclCkalloc.obj \ $(TMP_DIR)\tclClock.obj \ $(TMP_DIR)\tclCmdAH.obj \ $(TMP_DIR)\tclCmdIL.obj \ $(TMP_DIR)\tclCmdMZ.obj \ $(TMP_DIR)\tclCompCmds.obj \ $(TMP_DIR)\tclCompCmdsGR.obj \ $(TMP_DIR)\tclCompCmdsSZ.obj \ $(TMP_DIR)\tclCompExpr.obj \ | > | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 | $(TMP_DIR)\tclAlloc.obj \ $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ $(TMP_DIR)\tclBinary.obj \ $(TMP_DIR)\tclCkalloc.obj \ $(TMP_DIR)\tclClock.obj \ $(TMP_DIR)\tclClockFmt.obj \ $(TMP_DIR)\tclCmdAH.obj \ $(TMP_DIR)\tclCmdIL.obj \ $(TMP_DIR)\tclCmdMZ.obj \ $(TMP_DIR)\tclCompCmds.obj \ $(TMP_DIR)\tclCompCmdsGR.obj \ $(TMP_DIR)\tclCompCmdsSZ.obj \ $(TMP_DIR)\tclCompExpr.obj \ |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 279 280 281 282 283 284 285 | $(TMP_DIR)\tclEvent.obj \ $(TMP_DIR)\tclExecute.obj \ $(TMP_DIR)\tclFCmd.obj \ $(TMP_DIR)\tclFileName.obj \ $(TMP_DIR)\tclGet.obj \ $(TMP_DIR)\tclHash.obj \ $(TMP_DIR)\tclHistory.obj \ $(TMP_DIR)\tclIndexObj.obj \ $(TMP_DIR)\tclInterp.obj \ $(TMP_DIR)\tclIO.obj \ $(TMP_DIR)\tclIOCmd.obj \ $(TMP_DIR)\tclIOGT.obj \ $(TMP_DIR)\tclIOSock.obj \ $(TMP_DIR)\tclIOUtil.obj \ | > | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | $(TMP_DIR)\tclEvent.obj \ $(TMP_DIR)\tclExecute.obj \ $(TMP_DIR)\tclFCmd.obj \ $(TMP_DIR)\tclFileName.obj \ $(TMP_DIR)\tclGet.obj \ $(TMP_DIR)\tclHash.obj \ $(TMP_DIR)\tclHistory.obj \ $(TMP_DIR)\tclIcu.obj \ $(TMP_DIR)\tclIndexObj.obj \ $(TMP_DIR)\tclInterp.obj \ $(TMP_DIR)\tclIO.obj \ $(TMP_DIR)\tclIOCmd.obj \ $(TMP_DIR)\tclIOGT.obj \ $(TMP_DIR)\tclIOSock.obj \ $(TMP_DIR)\tclIOUtil.obj \ |
| ︙ | ︙ | |||
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 | $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclOO.obj \ $(TMP_DIR)\tclOOBasic.obj \ $(TMP_DIR)\tclOOCall.obj \ $(TMP_DIR)\tclOODefineCmds.obj \ $(TMP_DIR)\tclOOInfo.obj \ $(TMP_DIR)\tclOOMethod.obj \ $(TMP_DIR)\tclOOStubInit.obj \ $(TMP_DIR)\tclObj.obj \ $(TMP_DIR)\tclOptimize.obj \ $(TMP_DIR)\tclPanic.obj \ $(TMP_DIR)\tclParse.obj \ $(TMP_DIR)\tclPathObj.obj \ $(TMP_DIR)\tclPipe.obj \ $(TMP_DIR)\tclPkg.obj \ $(TMP_DIR)\tclPkgConfig.obj \ $(TMP_DIR)\tclPosixStr.obj \ $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ $(TMP_DIR)\tclStrToD.obj \ $(TMP_DIR)\tclStubInit.obj \ $(TMP_DIR)\tclThread.obj \ $(TMP_DIR)\tclThreadAlloc.obj \ $(TMP_DIR)\tclThreadJoin.obj \ $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ | > > | 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 | $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclOO.obj \ $(TMP_DIR)\tclOOBasic.obj \ $(TMP_DIR)\tclOOCall.obj \ $(TMP_DIR)\tclOODefineCmds.obj \ $(TMP_DIR)\tclOOInfo.obj \ $(TMP_DIR)\tclOOMethod.obj \ $(TMP_DIR)\tclOOProp.obj \ $(TMP_DIR)\tclOOStubInit.obj \ $(TMP_DIR)\tclObj.obj \ $(TMP_DIR)\tclOptimize.obj \ $(TMP_DIR)\tclPanic.obj \ $(TMP_DIR)\tclParse.obj \ $(TMP_DIR)\tclPathObj.obj \ $(TMP_DIR)\tclPipe.obj \ $(TMP_DIR)\tclPkg.obj \ $(TMP_DIR)\tclPkgConfig.obj \ $(TMP_DIR)\tclPosixStr.obj \ $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ $(TMP_DIR)\tclStrIdxTree.obj \ $(TMP_DIR)\tclStrToD.obj \ $(TMP_DIR)\tclStubInit.obj \ $(TMP_DIR)\tclThread.obj \ $(TMP_DIR)\tclThreadAlloc.obj \ $(TMP_DIR)\tclThreadJoin.obj \ $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ |
| ︙ | ︙ | |||
363 364 365 366 367 368 369 | $(TMP_DIR)\bn_mp_cnt_lsb.obj \ $(TMP_DIR)\bn_mp_copy.obj \ $(TMP_DIR)\bn_mp_count_bits.obj \ $(TMP_DIR)\bn_mp_div.obj \ $(TMP_DIR)\bn_mp_div_d.obj \ $(TMP_DIR)\bn_mp_div_2.obj \ $(TMP_DIR)\bn_mp_div_2d.obj \ | | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 | $(TMP_DIR)\bn_mp_cnt_lsb.obj \ $(TMP_DIR)\bn_mp_copy.obj \ $(TMP_DIR)\bn_mp_count_bits.obj \ $(TMP_DIR)\bn_mp_div.obj \ $(TMP_DIR)\bn_mp_div_d.obj \ $(TMP_DIR)\bn_mp_div_2.obj \ $(TMP_DIR)\bn_mp_div_2d.obj \ $(TMP_DIR)\bn_s_mp_div_3.obj \ $(TMP_DIR)\bn_mp_exch.obj \ $(TMP_DIR)\bn_mp_expt_n.obj \ $(TMP_DIR)\bn_mp_get_mag_u64.obj \ $(TMP_DIR)\bn_mp_grow.obj \ $(TMP_DIR)\bn_mp_init.obj \ $(TMP_DIR)\bn_mp_init_copy.obj \ $(TMP_DIR)\bn_mp_init_i64.obj \ $(TMP_DIR)\bn_mp_init_multi.obj \ $(TMP_DIR)\bn_mp_init_set.obj \ |
| ︙ | ︙ | |||
458 459 460 461 462 463 464 | $(TMP_DIR)\tclWinPanic.obj ### The following paths CANNOT have spaces in them as they appear on ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs | > | | > > > > | 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 | $(TMP_DIR)\tclWinPanic.obj ### The following paths CANNOT have spaces in them as they appear on ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs LIBTCLVFSSUBDIR = libtcl.vfs LIBTCLVFS = $(OUT_DIR)\$(LIBTCLVFSSUBDIR) # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" PRJ_DEFINES = /DMP_PREC=4 /Dinline=__inline /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS !if $(STATIC_BUILD) PRJ_DEFINES = $(PRJ_DEFINES) /DTCL_WITH_INTERNAL_ZLIB !endif # Additional Link libraries needed beyond those in rules.vc PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib #--------------------------------------------------------------------- # TclTest flags #--------------------------------------------------------------------- |
| ︙ | ︙ | |||
648 649 650 651 652 653 654 | $(TCLSCRIPTZIP): $(TCLLIB) $(TCLSH) dlls @echo Building Tcl library zip file $(TCLSCRIPTZIP) @set TCL_LIBRARY=$(ROOT:\=/)/library @if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)" @$(MKDIR) "$(LIBTCLVFS)" @$(CPYDIR) $(LIBDIR) "$(LIBTCLVFS)\tcl_library" @move /y "$(LIBTCLVFS)\tcl_library\manifest.txt" "$(LIBTCLVFS)\tcl_library\pkgIndex.tcl" > NUL | < < < < < | | > | | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 |
$(TCLSCRIPTZIP): $(TCLLIB) $(TCLSH) dlls
@echo Building Tcl library zip file $(TCLSCRIPTZIP)
@set TCL_LIBRARY=$(ROOT:\=/)/library
@if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)"
@$(MKDIR) "$(LIBTCLVFS)"
@$(CPYDIR) $(LIBDIR) "$(LIBTCLVFS)\tcl_library"
@move /y "$(LIBTCLVFS)\tcl_library\manifest.txt" "$(LIBTCLVFS)\tcl_library\pkgIndex.tcl" > NUL
# Remove the registry and dde directories as the DLLS are still external
@del "$(LIBTCLVFS)\tcl_library\registry\pkgIndex.tcl"
@rmdir "$(LIBTCLVFS)\tcl_library\registry"
@del "$(LIBTCLVFS)\tcl_library\dde\pkgIndex.tcl"
@rmdir "$(LIBTCLVFS)\tcl_library\dde"
@echo cd {$(OUT_DIR)} > "$(OUT_DIR)\zipper.tcl"
@echo file delete -force {$(@F)} >> "$(OUT_DIR)\zipper.tcl"
@echo zipfs mkzip {$(@F)} {$(LIBTCLVFSSUBDIR)} {$(LIBTCLVFSSUBDIR)} >> "$(OUT_DIR)\zipper.tcl"
@$(TCLSH_NATIVE) "$(OUT_DIR)/zipper.tcl"
pkgs:
@for /d %d in ($(PKGSDIR)\*) do \
@if exist "%~fd\win\makefile.vc" ( \
pushd "%~fd\win" & \
$(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\
popd \
|
| ︙ | ︙ | |||
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 | clean-pkgs: @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ popd \ ) #--------------------------------------------------------------------- # Regenerate the stubs files. [Development use only] #--------------------------------------------------------------------- genstubs: !if !exist($(TCLSH)) @echo Build tclsh first! !else $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ $(GENERICDIR:\=/)/tclTomMath.decls $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ $(GENERICDIR:\=/)/tclOO.decls !endif #--------------------------------------------------------------------- # Build the Windows HTML help file. #--------------------------------------------------------------------- | > > > > > > > > > < < | | | > > | | | | | | | | | 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 |
clean-pkgs:
@for /d %d in ($(PKGSDIR)\*) do \
@if exist "%~fd\win\makefile.vc" ( \
pushd "%~fd\win" & \
$(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\
popd \
)
hose-pkgs:
@for /d %d in ($(PKGSDIR)\*) do \
@if exist "%~fd\win\makefile.vc" ( \
pushd "%~fd\win" & \
$(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) hose &\
popd \
)
#---------------------------------------------------------------------
# Regenerate the stubs files. [Development use only]
#---------------------------------------------------------------------
genstubs:
!if !exist($(TCLSH))
@echo Build tclsh first!
!else
$(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
$(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \
$(GENERICDIR:\=/)/tclTomMath.decls
$(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
$(GENERICDIR:\=/)/tclOO.decls
!endif
#---------------------------------------------------------------------
# Build the Windows HTML help file.
#---------------------------------------------------------------------
!if defined(PROCESSOR_ARCHITECTURE) && "$(PROCESSOR_ARCHITECTURE)" == "AMD64"
HHC="%ProgramFiles(x86)%\HTML Help Workshop\hhc.exe"
!else
HHC="%ProgramFiles%\HTML Help Workshop\hhc.exe"
!endif
HTMLDIR=$(OUT_DIR)\html
HTMLBASE=TclTk$(VERSION)
HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp
CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm
htmlhelp: $(CHMFILE)
htmldocs: $(DOCDIR)\*
@$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)"
$(CHMFILE): htmldocs chmsetup
@echo Compiling HTML help project
-"$(HHC)" <<$(HHPFILE) >NUL
[OPTIONS]
Compatibility=1.1 or later
Compiled file=$(HTMLBASE).chm
Default topic=index.html
Display compile progress=no
Error log file=$(HTMLBASE).log
Full-text search=Yes
Language=0x409 English (United States)
Title=Tcl/Tk $(DOTVERSION) Help
[FILES]
index.html
docs.css
Keywords\*.html
TclCmd\*.html
TclLib\*.html
TkCmd\*.html
TkLib\*.html
UserCmd\*.html
<<
chmsetup:
@if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR)
install-docs:
!if exist("$(CHMFILE)")
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 | #--------------------------------------------------------------------- tclConfig: $(OUT_DIR)\tclConfig.sh # TBD - is this tclConfig.sh file ever used? The values are incorrect! $(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in @echo Creating tclConfig.sh | | | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 | #--------------------------------------------------------------------- tclConfig: $(OUT_DIR)\tclConfig.sh # TBD - is this tclConfig.sh file ever used? The values are incorrect! $(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in @echo Creating tclConfig.sh @nmakehlp -s << $** >$@ @TCL_DLL_FILE@ $(TCLLIBNAME) @TCL_VERSION@ $(DOTVERSION) @TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION) @TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION) @TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) @CC@ $(CC) @DEFS@ $(pkgcflags) |
| ︙ | ︙ | |||
815 816 817 818 819 820 821 | @LIBOBJS@ @RANLIB@ @TCL_LIB_FLAG@ $(PROJECT)$(VERSION)$(SUFX).lib @TCL_BUILD_LIB_SPEC@ $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib @TCL_LIB_SPEC@ $(LIB_INSTALL_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib @TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) @TCL_SRC_DIR@ $(ROOT) | | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 | @LIBOBJS@ @RANLIB@ @TCL_LIB_FLAG@ $(PROJECT)$(VERSION)$(SUFX).lib @TCL_BUILD_LIB_SPEC@ $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib @TCL_LIB_SPEC@ $(LIB_INSTALL_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib @TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) @TCL_SRC_DIR@ $(ROOT) @TCL_PACKAGE_PATH@ $(LIB_INSTALL_DIR) @TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) @TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME) @TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB) @TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME) @CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll |
| ︙ | ︙ | |||
867 868 869 870 871 872 873 | copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid git rev-parse HEAD >>$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h: $(ROOT)\manifest.uuid copy $(WIN_DIR)\tclUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h $(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h | | | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 | copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid git rev-parse HEAD >>$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h: $(ROOT)\manifest.uuid copy $(WIN_DIR)\tclUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h $(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -I$(TMP_DIR) \ -Fo$@ $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h $(cc32) $(appcflags) -I$(TMP_DIR) \ -Fo$@ $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c |
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 | @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(TOMMATHDIR)\tommath.h" "$(INCLUDE_INSTALL_DIR)\" !if !$(TCL_EMBED_SCRIPTS) @echo Installing library files to $(SCRIPT_INSTALL_DIR) @if not exist "$(SCRIPT_INSTALL_DIR)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" | | < < < < < < < < | 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 | @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(TOMMATHDIR)\tommath.h" "$(INCLUDE_INSTALL_DIR)\" !if !$(TCL_EMBED_SCRIPTS) @echo Installing library files to $(SCRIPT_INSTALL_DIR) @if not exist "$(SCRIPT_INSTALL_DIR)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" @$(CPY) "$(ROOT)\library\*.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" !endif @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" @$(CPY) "$(WIN_DIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" @$(CPY) "$(TCLSCRIPTZIP)" "$(LIB_INSTALL_DIR)\" @$(CPY) "$(WIN_DIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(WIN_DIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(WIN_DIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\" |
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 | @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\platform-$(PKG_PLATFORM_VER).tm" @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\platform\shell-$(PKG_SHELL_VER).tm" !endif @echo Installing $(TCLDDELIBNAME) | < < < < | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 | @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\platform-$(PKG_PLATFORM_VER).tm" @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ "$(MODULE_INSTALL_DIR)\9.0\platform\shell-$(PKG_SHELL_VER).tm" !endif @echo Installing $(TCLDDELIBNAME) @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" @$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \ "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" @echo Installing $(TCLREGLIBNAME) @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\registry$(REGDOTVERSION)\" @$(CPY) "$(ROOT)\library\registry\pkgIndex.tcl" \ "$(LIB_INSTALL_DIR)\registry$(REGDOTVERSION)\" !if !$(TCL_EMBED_SCRIPTS) @echo Installing encodings @$(CPY) "$(ROOT)\library\encoding\*.enc" \ "$(SCRIPT_INSTALL_DIR)\encoding\" !endif # "emacs font-lock highlighting fix |
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 | @if exist $(TCLTEST) del $(TCLTEST) @echo Removing $(TCLDDELIB) ... @if exist $(TCLDDELIB) del $(TCLDDELIB) @echo Removing $(TCLREGLIB) ... @if exist $(TCLREGLIB) del $(TCLREGLIB) clean: default-clean clean-pkgs | | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 | @if exist $(TCLTEST) del $(TCLTEST) @echo Removing $(TCLDDELIB) ... @if exist $(TCLDDELIB) del $(TCLDDELIB) @echo Removing $(TCLREGLIB) ... @if exist $(TCLREGLIB) del $(TCLREGLIB) clean: default-clean clean-pkgs hose: default-hose hose-pkgs realclean: hose .PHONY: # Local Variables: # mode: makefile # End: |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
SetEnvironmentVariable("LINK", "");
if (argc > 1 && *argv[1] == '-') {
switch (*(argv[1]+1)) {
case 'c':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
| | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
SetEnvironmentVariable("LINK", "");
if (argc > 1 && *argv[1] == '-') {
switch (*(argv[1]+1)) {
case 'c':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c <compiler option>\n"
"Tests for whether cl.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return CheckForCompilerFeature(argv[2]);
case 'l':
if (argc < 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -l <linker option> ?<mandatory option> ...?\n"
"Tests for whether link.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return CheckForLinkerFeature(&argv[2], argc-2);
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
| | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 |
/*
* Look for the commandline warning code in both streams.
* - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
*/
return !(strstr(Out.buffer, "D4002") != NULL
| | | | | | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
/*
* Look for the commandline warning code in both streams.
* - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
*/
return !(strstr(Out.buffer, "D4002") != NULL
|| strstr(Err.buffer, "D4002") != NULL
|| strstr(Out.buffer, "D9002") != NULL
|| strstr(Err.buffer, "D9002") != NULL
|| strstr(Out.buffer, "D2021") != NULL
|| strstr(Err.buffer, "D2021") != NULL);
}
static int
CheckForLinkerFeature(
char **options,
int count)
{
|
| ︙ | ︙ | |||
401 402 403 404 405 406 407 |
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
| | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 |
const char *substring)
{
return (strstr(string, substring) != NULL);
}
/*
* GetVersionFromFile --
| | | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
const char *substring)
{
return (strstr(string, substring) != NULL);
}
/*
* GetVersionFromFile --
* Looks for a match string in a file and then returns the version
* following the match where a version is anything acceptable to
* package provide or package ifneeded.
*/
static const char *
GetVersionFromFile(
const char *filename,
const char *match,
int numdots)
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 | * option here to handle autoconf style substitutions. * The substitution file is whitespace and line delimited. The file should * consist of lines matching the regular expression: * \s*\S+\s+\S*$ * * Usage is something like: * nmakehlp -S << $** > $@ | | | | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 |
* option here to handle autoconf style substitutions.
* The substitution file is whitespace and line delimited. The file should
* consist of lines matching the regular expression:
* \s*\S+\s+\S*$
*
* Usage is something like:
* nmakehlp -S << $** > $@
* @PACKAGE_NAME@ $(PACKAGE_NAME)
* @PACKAGE_VERSION@ $(PACKAGE_VERSION)
* <<
*/
static int
SubstituteFile(
const char *substitutions,
const char *filename)
{
|
| ︙ | ︙ | |||
743 744 745 746 747 748 749 |
* 1 -> FindExSearchLimitToDirectories,
* as these are not defined in Visual C++ 6
*/
hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
#else
hSearch = FindFirstFile(path, &finfo);
#endif
| | > | > | > | | | | | | | 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 |
* 1 -> FindExSearchLimitToDirectories,
* as these are not defined in Visual C++ 6
*/
hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
#else
hSearch = FindFirstFile(path, &finfo);
#endif
if (hSearch == INVALID_HANDLE_VALUE) {
return 1; /* Not found */
}
/* Loop through all subdirs checking if the keypath is under there */
ret = 1; /* Assume not found */
do {
int sublen;
/*
* We need to check it is a directory despite the
* FindExSearchLimitToDirectories in the above call. See SDK docs
*/
if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) {
continue;
}
sublen = strlen(finfo.cFileName);
if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) {
continue; /* Path does not fit, assume not matched */
}
strncpy(path+dirlen+1, finfo.cFileName, sublen);
path[dirlen+1+sublen] = '\\';
strncpy(path+dirlen+1+sublen+1, keypath, keylen+1);
if (FileExists(path)) {
/* Found a match, print to stdout */
path[dirlen+1+sublen] = '\0';
QualifyPath(path);
ret = 0;
break;
}
} while (FindNextFile(hSearch, &finfo));
FindClose(hSearch);
return ret;
}
/*
* LocateDependency --
*
* Locates a dependency for a package.
* keypath - a relative path within the package directory
* that is used to confirm it is the correct directory.
* The search path for the package directory is currently only
* the parent and grandparent of the current working directory.
* If found, the command prints
* name_DIRPATH=<full path of located directory>
* and returns 0. If not found, does not print anything and returns 1.
*/
static int LocateDependency(const char *keypath)
{
size_t i;
int ret;
static const char *paths[] = {"..", "..\\..", "..\\..\\.."};
|
| ︙ | ︙ |
Changes to win/rules.vc.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 RULES_VERSION_MINOR = 13 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif !if "$(PRJ_PACKAGE_TCLNAME)" == "" |
| ︙ | ︙ | |||
877 878 879 880 881 882 883 884 885 886 887 888 889 890 | USE_THREAD_ALLOC= 0 !endif !if [nmakehlp -f $(OPTS) "tcl8"] !message *** Build for Tcl8 TCL_BUILD_FOR = 8 !endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif !endif | > > > > | 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 | USE_THREAD_ALLOC= 0 !endif !if [nmakehlp -f $(OPTS) "tcl8"] !message *** Build for Tcl8 TCL_BUILD_FOR = 8 !endif !if [nmakehlp -f $(OPTS) "tk8"] !message *** Build for Tk8 TK_BUILD_FOR = 8 !endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif !endif |
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 | STUBPREFIX = $(PROJECT)stub # # Set up paths to various Tcl executables and libraries needed by extensions # # TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc | | | | | 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 | STUBPREFIX = $(PROJECT)stub # # Set up paths to various Tcl executables and libraries needed by extensions # # TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc TCL_ZIP_FILE = libtcl$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip TK_ZIP_FILE = libtk$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip !if $(DOING_TCL) TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSCRIPTZIP = $(OUT_DIR)\$(TCL_ZIP_FILE) !if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib !else TCLSTUBLIBNAME = $(STUBPREFIX).lib !endif TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) |
| ︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 |
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\lib
TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib
| | | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\lib
TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib
TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCL_ZIP_FILE)
TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
TCL_INCLUDES = -I"$(_TCLDIR)\include"
!else # Building against Tcl sources
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!if !exist($(TCLSH))
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\library
TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib
| | | 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 |
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\library
TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib
TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCL_ZIP_FILE)
TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif # TCLINSTALL
!if !$(STATIC_BUILD) && "$(TCL_BUILD_FOR)" == "8"
tcllibs = "$(TCLSTUBLIB)"
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | !if $(TK_MAJOR_VERSION) == 8 TKSTUBLIBNAME = tkstub$(TK_VERSION).lib !else TKSTUBLIBNAME = tkstub.lib !endif !if $(DOING_TK) | | | | | > | | 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 |
!if $(TK_MAJOR_VERSION) == 8
TKSTUBLIBNAME = tkstub$(TK_VERSION).lib
!else
TKSTUBLIBNAME = tkstub.lib
!endif
!if $(DOING_TK)
WISH = $(OUT_DIR)\$(WISHNAME)
TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME)
TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME)
TKLIB = $(OUT_DIR)\$(TKLIBNAME)
TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
TKSCRIPTZIP = $(OUT_DIR)\$(TK_ZIP_FILE)
!else # effectively NEED_TK
!if $(TKINSTALL) # Building against installed Tk
WISH = $(_TKDIR)\bin\$(WISHNAME)
TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME)
TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME)
# When building extensions, may be linking against Tk that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TKIMPLIB)")
TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib
TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME)
!endif
TK_INCLUDES = -I"$(_TKDIR)\include"
TKSCRIPTZIP = $(_TKDIR)\lib\$(TK_ZIP_FILE)
!else # Building against Tk sources
WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME)
TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME)
TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME)
# When building extensions, may be linking against Tk that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TKIMPLIB)")
TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib
TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME)
!endif
TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib"
TKSCRIPTZIP = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TK_ZIP_FILE)
!endif # TKINSTALL
tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)"
!endif # $(DOING_TK)
!endif # $(DOING_TK) || $(NEED_TK)
# Various output paths
PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
# Even when building against Tcl 8, PRJLIBNAME9 must not have "t"
PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX:t=).$(EXT)
!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8"
PRJLIBNAME = $(PRJLIBNAME8)
!else
PRJLIBNAME = $(PRJLIBNAME9)
!endif
PRJLIB = $(OUT_DIR)\$(PRJLIBNAME)
|
| ︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 | OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif !if $(TCL_MAJOR_VERSION) == 8 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif | < < < > > > | | | | 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 | OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif !if $(TCL_MAJOR_VERSION) == 8 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif !endif !if "$(TCL_BUILD_FOR)" == "8" OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 !endif !if "$(TK_BUILD_FOR)" == "8" OPTDEFINES = $(OPTDEFINES) /DTK_MAJOR_VERSION=8 !endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ /DMODULE_SCOPE=extern !endif # crt picks the C run time based on selected OPTS !if $(MSVCRT) !if $(DEBUG) && !$(UNCHECKED) crt = -MDd !else |
| ︙ | ︙ | |||
1794 1795 1796 1797 1798 1799 1800 |
#endif
FILEOS VOS_NT_WINDOWS32
FILETYPE VFT_DLL
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
| | | | | | | | | | | 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 |
#endif
FILEOS VOS_NT_WINDOWS32
FILETYPE VFT_DLL
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "Tcl extension " PROJECT
VALUE "OriginalFilename", PRJLIBNAME
VALUE "FileVersion", DOTVERSION
VALUE "ProductName", "Package " PROJECT " for Tcl"
VALUE "ProductVersion", DOTVERSION
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END
<<
!endif # ifdef RCFILE
|
| ︙ | ︙ |
Changes to win/tcl.m4.
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
#
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
| | | | | | | 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 |
#
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TCL_BIN_DIR}/tclConfig.sh"
else
AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh])
fi
#
# If the TCL_BIN_DIR is the build directory (not the install directory),
# then set the common variable name to the value of the build variables.
# For example, the variable TCL_LIB_SPEC will be set to the value
# of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC
# instead of TCL_BUILD_LIB_SPEC since it will work with both an
# installed and uninstalled version of Tcl.
#
if test -f $TCL_BIN_DIR/Makefile ; then
TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
fi
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
AC_SUBST(TCL_VERSION)
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 |
# TK_BIN_DIR
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TKCONFIG], [
AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh])
if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
| | | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
# TK_BIN_DIR
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TKCONFIG], [
AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh])
if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TK_BIN_DIR}/tkConfig.sh"
else
AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh])
fi
AC_SUBST(TK_BIN_DIR)
AC_SUBST(TK_SRC_DIR)
AC_SUBST(TK_LIB_FILE)
])
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
CYGPATH=echo
fi
conftest=
cyg_conftest=
fi
if test "$CYGPATH" = "echo"; then
| | | | | 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 |
CYGPATH=echo
fi
conftest=
cyg_conftest=
fi
if test "$CYGPATH" = "echo"; then
DEPARG='"$<"'
else
DEPARG='"$(shell $(CYGPATH) $<)"'
fi
# set various compiler flags depending on whether we are using gcc or cl
if test "${GCC}" = "yes" ; then
extra_cflags="-pipe"
extra_ldflags="-pipe -static-libgcc"
AC_CACHE_CHECK(for mingw32 version of gcc,
ac_cv_win32,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#ifdef _WIN32
#error win32
#endif
]], [[]])],
[ac_cv_win32=no],
[ac_cv_win32=yes])
)
if test "$ac_cv_win32" != "yes"; then
AC_MSG_ERROR([${CC} cannot produce win32 executables.])
fi
if test "$do64bit" != "arm64" -a "$do64bit" != "aarch64"; then
extra_cflags="$extra_cflags -DHAVE_CPUID=1"
fi
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain"
AC_CACHE_CHECK(for working -municode linker flag,
ac_cv_municode,
AC_LINK_IFELSE([AC_LANG_PROGRAM([[
|
| ︙ | ︙ | |||
640 641 642 643 644 645 646 |
AC_CACHE_CHECK(for working --enable-auto-image-base,
ac_cv_enable_auto_image_base,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([])],
[ac_cv_enable_auto_image_base=yes],
[ac_cv_enable_auto_image_base=no])
)
CFLAGS=$hold_cflags
| | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
AC_CACHE_CHECK(for working --enable-auto-image-base,
ac_cv_enable_auto_image_base,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([])],
[ac_cv_enable_auto_image_base=yes],
[ac_cv_enable_auto_image_base=no])
)
CFLAGS=$hold_cflags
if test "$ac_cv_enable_auto_image_base" = "yes" ; then
extra_ldflags="$extra_ldflags -Wl,--enable-auto-image-base"
fi
AC_MSG_CHECKING([compiler flags])
if test "${GCC}" = "yes" ; then
SHLIB_LD=""
SHLIB_LD_LIBS='${LIBS}'
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
MAKE_STUB_LIB="\${STLIB_LD} \[$]@"
POST_MAKE_LIB="\${RANLIB} \[$]@"
MAKE_EXE="\${CC} -o \[$]@"
LIBPREFIX="lib"
if test "${SHARED_BUILD}" = "0" ; then
# static
| | | | | 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 |
MAKE_STUB_LIB="\${STLIB_LD} \[$]@"
POST_MAKE_LIB="\${RANLIB} \[$]@"
MAKE_EXE="\${CC} -o \[$]@"
LIBPREFIX="lib"
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
# ad-hoc check to see if CC supports -shared.
if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
AC_MSG_ERROR([${CC} does not support the -shared option.
You will need to upgrade to a newer version of the toolchain.])
fi
runtime=
# Add SHLIB_LD_LIBS to the Make rule, not here.
EXESUFFIX=".exe"
LIBRARIES="\${SHARED_LIBRARIES}"
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
AC_MSG_RESULT([ Using 64-bit $MACHINE mode])
fi
;;
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
| | | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
AC_MSG_RESULT([ Using 64-bit $MACHINE mode])
fi
;;
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
LIBRARIES="\${SHARED_LIBRARIES}"
EXESUFFIX=".exe"
case "x`echo \${VisualStudioVersion}`" in
x1[[4-9]]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 |
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
AC_MSG_CHECKING([for zip])
AC_CACHE_VAL(ac_cv_path_zip, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
AC_MSG_CHECKING([for zip])
AC_CACHE_VAL(ac_cv_path_zip, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/zip 2> /dev/null` \
`ls -r $dir/zip 2> /dev/null` ; do
if test x"$ac_cv_path_zip" = x ; then
if test -f "$j" ; then
ac_cv_path_zip=$j
break
fi
fi
done
done
])
if test -f "$ac_cv_path_zip" ; then
ZIP_PROG="$ac_cv_path_zip"
AC_MSG_RESULT([$ZIP_PROG])
ZIP_PROG_OPTIONS="-rq"
ZIP_PROG_VFSSEARCH="*"
AC_MSG_RESULT([Found INFO Zip in environment])
# Use standard arguments for zip
else
# It is not an error if an installed version of Zip can't be located.
# We can use the locally distributed minizip instead
ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
ZIP_PROG_OPTIONS="-o -r"
ZIP_PROG_VFSSEARCH="*"
ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
AC_MSG_RESULT([No zip found on PATH building minizip])
fi
AC_SUBST(ZIP_PROG)
AC_SUBST(ZIP_PROG_OPTIONS)
AC_SUBST(ZIP_PROG_VFSSEARCH)
AC_SUBST(ZIP_INSTALL_OBJS)
])
|
Changes to win/tcl.rc.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | #define SUFFIX SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO | | | | | | | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
#define SUFFIX SUFFIX_DEBUG
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
VS_VERSION_INFO VERSIONINFO
FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
FILEFLAGSMASK 0x3fL
#ifdef DEBUG
FILEFLAGS VS_FF_DEBUG
#else
FILEFLAGS 0x0L
#endif
FILEOS VOS__WINDOWS32
FILETYPE VFT_DLL
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
BEGIN
VALUE "FileDescription", "Tcl DLL\0"
VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".dll\0"
|
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
* Specify a user-specific startup file to invoke if the application is
* run interactively. Typically the startup file is "~/.apprc" where "app"
* is the name of the application. If this line is deleted then no
* user-specific startup file will be run under any conditions.
*/
(void)Tcl_EvalEx(interp,
| | < | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
* Specify a user-specific startup file to invoke if the application is
* run interactively. Typically the startup file is "~/.apprc" where "app"
* is the name of the application. If this line is deleted then no
* user-specific startup file will be run under any conditions.
*/
(void)Tcl_EvalEx(interp,
"set tcl_rcFileName [file tildeexpand ~/tclshrc.tcl]",
TCL_AUTO_LENGTH, TCL_EVAL_GLOBAL);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to win/tclWin32Dll.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright © 1998-2000 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" | | > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright © 1998-2000 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" #if defined(HAVE_CPUID_H) # include <cpuid.h> #elif defined(HAVE_INTRIN_H) # include <intrin.h> #endif /* * The following variables keep track of information about this DLL on a * per-instance basis. Each time this DLL is loaded, it gets its own new data * segment with its own copy of all static and global information. |
| ︙ | ︙ | |||
433 434 435 436 437 438 439 |
int
TclWinCPUID(
int index, /* Which CPUID value to retrieve. */
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
| > > > > > > | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
int
TclWinCPUID(
int index, /* Which CPUID value to retrieve. */
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
#if defined(HAVE_CPUID_H)
unsigned int *regs = (unsigned int *)regsPtr;
__get_cpuid(index, ®s[0], ®s[1], ®s[2], ®s[3]);
status = TCL_OK;
#elif defined(HAVE_INTRIN_H) && defined(_WIN64) && defined(HAVE_CPUID)
__cpuid((int *)regsPtr, index);
status = TCL_OK;
#elif defined(__GNUC__) && defined(HAVE_CPUID)
# if defined(_WIN64)
/*
|
| ︙ | ︙ |
Changes to win/tclWinChan.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclWinChan.c * * Channel drivers for Windows channels based on files, command pipes and * TCP sockets. * * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" #include "tclIO.h" /* * State flags used in the info structures below. */ #define FILE_PENDING (1<<0) /* Message is pending in the queue. */ | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclWinChan.c * * Channel drivers for Windows channels based on files, command pipes and * TCP sockets. * * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" #include "tclFileSystem.h" #include "tclIO.h" /* * State flags used in the info structures below. */ #define FILE_PENDING (1<<0) /* Message is pending in the queue. */ |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 | static void FileWatchProc(void *instanceData, int mask); static void FileThreadActionProc(void *instanceData, int action); static int FileTruncateProc(void *instanceData, long long length); static DWORD FileGetType(HANDLE handle); static int NativeIsComPort(const WCHAR *nativeName); | | | | | | | | | | | | | | | | | | < | 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 |
static void FileWatchProc(void *instanceData, int mask);
static void FileThreadActionProc(void *instanceData,
int action);
static int FileTruncateProc(void *instanceData,
long long length);
static DWORD FileGetType(HANDLE handle);
static int NativeIsComPort(const WCHAR *nativeName);
static Tcl_Channel OpenFileChannel(HANDLE handle, char *channelName,
int permissions, int appendMode);
/*
* This structure describes the channel type structure for file based IO.
*/
static const Tcl_ChannelType fileChannelType = {
"file",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
FileInputProc,
FileOutputProc,
NULL, /* Deprecated. */
NULL, /* Set option proc. */
FileGetOptionProc,
FileWatchProc,
FileGetHandleProc,
FileCloseProc,
FileBlockProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
FileWideSeekProc,
FileThreadActionProc,
FileTruncateProc
};
/*
* General useful clarification macros.
*/
#define SET_FLAG(var, flag) ((var) |= (flag))
#define CLEAR_FLAG(var, flag) ((var) &= ~(flag))
#define TEST_FLAG(value, flag) (((value) & (flag)) != 0)
/*
* The number of 100-ns intervals between the Windows system epoch (1601-01-01
* on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01).
*/
#define POSIX_EPOCH_AS_FILETIME \
((long long) 116444736 * (long long) 1000000000)
/*
*----------------------------------------------------------------------
*
* TclWinGenerateChannelName --
*
* This function generates names for channels.
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 |
{
FileInfo *infoPtr = (FileInfo *)instanceData;
if (!TEST_FLAG(direction, infoPtr->validMask)) {
return TCL_ERROR;
}
| | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
{
FileInfo *infoPtr = (FileInfo *)instanceData;
if (!TEST_FLAG(direction, infoPtr->validMask)) {
return TCL_ERROR;
}
*handlePtr = (void *)infoPtr->handle;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FileGetOptionProc --
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
ULARGE_INTEGER converter;
converter.LowPart = lo;
converter.HighPart = hi;
return converter.QuadPart;
}
| < < < < < < < < < < < < < < < | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 |
ULARGE_INTEGER converter;
converter.LowPart = lo;
converter.HighPart = hi;
return converter.QuadPart;
}
static inline time_t
ToCTime(
FILETIME fileTime) /* UTC time */
{
LARGE_INTEGER convertedTime;
convertedTime.LowPart = fileTime.dwLowDateTime;
|
| ︙ | ︙ | |||
888 889 890 891 892 893 894 |
mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6;
/*
* We don't construct a Tcl_StatBuf; we're using the info immediately.
*/
TclNewObj(dictObj);
| | | | | 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 |
mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6;
/*
* We don't construct a Tcl_StatBuf; we're using the info immediately.
*/
TclNewObj(dictObj);
#define STORE_ELEM(name, value) TclDictPut(NULL, dictObj, name, value)
STORE_ELEM("dev", Tcl_NewWideIntObj((long) dev));
STORE_ELEM("ino", Tcl_NewWideIntObj((long long) inode));
STORE_ELEM("nlink", Tcl_NewIntObj(nlink));
STORE_ELEM("uid", Tcl_NewIntObj(0));
STORE_ELEM("gid", Tcl_NewIntObj(0));
STORE_ELEM("size", Tcl_NewWideIntObj((long long) size));
STORE_ELEM("atime", Tcl_NewWideIntObj(atime));
STORE_ELEM("mtime", Tcl_NewWideIntObj(mtime));
STORE_ELEM("ctime", Tcl_NewWideIntObj(ctime));
STORE_ELEM("mode", Tcl_NewWideIntObj(mode));
/*
* Windows only has files and directories, as far as we're concerned.
* Anything else and we definitely couldn't have got here anyway.
*/
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
STORE_ELEM("type", Tcl_NewStringObj("directory", TCL_INDEX_NONE));
} else {
STORE_ELEM("type", Tcl_NewStringObj("file", TCL_INDEX_NONE));
}
#undef STORE_ELEM
return dictObj;
}
static int
|
| ︙ | ︙ | |||
957 958 959 960 961 962 963 | /* * Transfer dictionary to the DString. Note that we don't do this as * an element as this is an option that can't be retrieved with a * general probe. */ | | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
/*
* Transfer dictionary to the DString. Note that we don't do this as
* an element as this is an option that can't be retrieved with a
* general probe.
*/
dictContents = TclGetStringFromObj(dictObj, &dictLength);
Tcl_DStringAppend(dsPtr, dictContents, dictLength);
Tcl_DecrRefCount(dictObj);
return TCL_OK;
}
if (valid) {
return TCL_OK;
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": filename is invalid on this platform",
TclGetString(pathPtr)));
}
return NULL;
}
| > > > > > > > > > > > > > > > > > | | 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 |
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
if (interp) {
/*
* We need this just to ensure we return the correct error messages under
* some circumstances (relative paths only), so because the normalization
* is very expensive, don't invoke it for native or absolute paths.
* Note: since paths starting with ~ are relative in 9.0 for windows,
* it doesn't need to consider tilde expansion (in opposite to 8.x).
*/
if (
(
!TclFSCwdIsNative() &&
(Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE)
) &&
Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL
) {
return NULL;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": filename is invalid on this platform",
TclGetString(pathPtr)));
}
return NULL;
}
switch (mode & O_ACCMODE) {
case O_RDONLY:
accessMode = GENERIC_READ;
channelPermissions = TCL_READABLE;
break;
case O_WRONLY:
accessMode = GENERIC_WRITE;
channelPermissions = TCL_WRITABLE;
|
| ︙ | ︙ | |||
1190 1191 1192 1193 1194 1195 1196 | */ channel = NULL; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": bad file type", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", | | | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 |
*/
channel = NULL;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": bad file type",
TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE",
(char *)NULL);
break;
}
return channel;
}
/*
|
| ︙ | ︙ |
Changes to win/tclWinConsole.c.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 | * Locks are never held when calling the ReadConsole/WriteConsole API's * since they may block. */ static int gInitialized = 0; /* | > > > > > | > > | > > | | 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 |
* Locks are never held when calling the ReadConsole/WriteConsole API's
* since they may block.
*/
static int gInitialized = 0;
/*
* INPUT_BUFFER_SIZE is size of buffer passed to ReadConsole in bytes.
* Note that ReadConsole will only allow reading of line lengths up to the
* max of 256 and buffer size passed to it. So dropping this below 512
* means user can type at most 256 chars.
*/
#ifndef INPUT_BUFFER_SIZE
#define INPUT_BUFFER_SIZE 8192 /* In bytes, so 4096 chars */
#endif
/*
* CONSOLE_BUFFER_SIZE is size of storage used in ring buffers.
* In theory, at least sizeof(WCHAR) but note the Tcl channel bug
* https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c
* will cause failures in test suite if close to max input line in the suite.
*/
#ifndef CONSOLE_BUFFER_SIZE
#define CONSOLE_BUFFER_SIZE 8192 /* In bytes */
#endif
/*
* Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1]
* and bufPtr[0]:bufPtr[length - (size-start)].
*/
typedef struct RingBuffer {
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
* opening and dropped on channel close. This also covers the reference
* from gWatchingChannelList since queueing / dequeuing from that list
* happens in conjunction with channel operations.
* - the Tcl event queue entries. This reference is added when the event
* is queued and dropped on receipt.
*/
typedef struct ConsoleChannelInfo {
| | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
* opening and dropped on channel close. This also covers the reference
* from gWatchingChannelList since queueing / dequeuing from that list
* happens in conjunction with channel operations.
* - the Tcl event queue entries. This reference is added when the event
* is queued and dropped on receipt.
*/
typedef struct ConsoleChannelInfo {
HANDLE handle; /* Console handle */
Tcl_ThreadId threadId; /* Id of owning thread */
struct ConsoleChannelInfo *nextWatchingChannelPtr;
/* Pointer to next channel watching events. */
Tcl_Channel channel; /* Pointer to channel structure. */
DWORD initMode; /* Initial console mode. */
int numRefs; /* See comments above */
int permissions; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
int watchMask; /* OR'ed combination of TCL_READABLE,
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
/*
* The following structure is what is added to the Tcl event queue when
* console events are generated.
*/
typedef struct {
| | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
/*
* The following structure is what is added to the Tcl event queue when
* console events are generated.
*/
typedef struct {
Tcl_Event header; /* Information that is standard for all events. */
ConsoleChannelInfo *chanInfoPtr;
/* Pointer to console info structure. Note
* that we still have to verify that the
* console exists before dereferencing this
* pointer. */
} ConsoleEvent;
/*
* Declarations for functions used only in this file.
*/
static int ConsoleBlockModeProc(void *instanceData, int mode);
static void ConsoleCheckProc(void *clientData, int flags);
static int ConsoleCloseProc(void *instanceData,
Tcl_Interp *interp, int flags);
static int ConsoleEventProc(Tcl_Event *evPtr, int flags);
static void ConsoleExitHandler(void *clientData);
static int ConsoleGetHandleProc(void *instanceData,
int direction, void **handlePtr);
static int ConsoleGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static void ConsoleInit(void);
static int ConsoleInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
static int ConsoleOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
static int ConsoleSetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
static void ConsoleSetupProc(void *clientData, int flags);
static void ConsoleWatchProc(void *instanceData, int mask);
static void ProcExitHandler(void *clientData);
static void ConsoleThreadActionProc(void *instanceData, int action);
static DWORD ReadConsoleChars(HANDLE hConsole, WCHAR *lpBuffer,
Tcl_Size nChars, Tcl_Size *nCharsReadPtr);
static DWORD WriteConsoleChars(HANDLE hConsole,
const WCHAR *lpBuffer, Tcl_Size nChars,
Tcl_Size *nCharsWritten);
static void RingBufferInit(RingBuffer *ringPtr, Tcl_Size capacity);
static void RingBufferClear(RingBuffer *ringPtr);
static Tcl_Size RingBufferIn(RingBuffer *ringPtr, const char *srcPtr,
Tcl_Size srcLen, int partialCopyOk);
static Tcl_Size RingBufferOut(RingBuffer *ringPtr, char *dstPtr,
Tcl_Size dstCapacity, int partialCopyOk);
static ConsoleHandleInfo *AllocateConsoleHandleInfo(HANDLE consoleHandle,
int permissions);
static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *);
static DWORD WINAPI ConsoleReaderThread(LPVOID arg);
static DWORD WINAPI ConsoleWriterThread(LPVOID arg);
static void NudgeWatchers(HANDLE consoleHandle);
#ifndef NDEBUG
static int RingBufferCheck(const RingBuffer *ringPtr);
#endif
/*
* Static data.
*/
typedef struct {
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 | * stdout and stderr), and contention low. More finer-grained locking would * likely not only complicate implementation but be slower due to multiple * locks being held. Note console channels also differ from other Tcl * channel types in that the channel<->OS descriptor mapping is not one-to-one. */ SRWLOCK gConsoleLock; | < | | | | | | | | | | | | | | | | | | > > | 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 |
* stdout and stderr), and contention low. More finer-grained locking would
* likely not only complicate implementation but be slower due to multiple
* locks being held. Note console channels also differ from other Tcl
* channel types in that the channel<->OS descriptor mapping is not one-to-one.
*/
SRWLOCK gConsoleLock;
/* Process-wide list of console handles. Access control through gConsoleLock */
static ConsoleHandleInfo *gConsoleHandleInfoList;
/*
* Process-wide list of channels that are listening for events. Again access
* control through gConsoleLock. Common list for all threads is simplifies
* locking and bookkeeping and is workable because in practice multiple
* threads are very unlikely to be all waiting on stdin (not workable
* because input would be randomly distributed to threads)
*/
static ConsoleChannelInfo *gWatchingChannelList;
/*
* This structure describes the channel type structure for command console
* based IO.
*/
static const Tcl_ChannelType consoleChannelType = {
"console",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
ConsoleInputProc,
ConsoleOutputProc,
NULL, /* Deprecated. */
ConsoleSetOptionProc,
ConsoleGetOptionProc,
ConsoleWatchProc,
ConsoleGetHandleProc,
ConsoleCloseProc,
ConsoleBlockModeProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
NULL, /* Seek proc. */
ConsoleThreadActionProc,
NULL /* Truncation proc. */
};
/*
*------------------------------------------------------------------------
*
* RingBufferInit --
*
* Initializes the ring buffer to a given size.
*
* Results:
* None.
*
* Side effects:
* Panics on allocation failure.
*
*------------------------------------------------------------------------
*/
static void
RingBufferInit(
RingBuffer *ringPtr,
Tcl_Size capacity)
{
if (capacity <= 0 || capacity > TCL_SIZE_MAX) {
Tcl_Panic("Internal error: invalid ring buffer capacity requested.");
}
ringPtr->bufPtr = (char *)Tcl_Alloc(capacity);
ringPtr->capacity = capacity;
ringPtr->start = 0;
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 | * * Side effects: * The allocated internal buffer is freed. * *------------------------------------------------------------------------ */ static void | | > | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
*
* Side effects:
* The allocated internal buffer is freed.
*
*------------------------------------------------------------------------
*/
static void
RingBufferClear(
RingBuffer *ringPtr)
{
if (ringPtr->bufPtr) {
Tcl_Free(ringPtr->bufPtr);
ringPtr->bufPtr = NULL;
}
ringPtr->capacity = 0;
ringPtr->start = 0;
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
* Internal buffer is updated.
*
*------------------------------------------------------------------------
*/
static Tcl_Size
RingBufferIn(
RingBuffer *ringPtr,
| | | | < | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
* Internal buffer is updated.
*
*------------------------------------------------------------------------
*/
static Tcl_Size
RingBufferIn(
RingBuffer *ringPtr,
const char *srcPtr, /* Source to be copied */
Tcl_Size srcLen, /* Length of source */
int partialCopyOk) /* If true, partial copy is permitted */
{
Tcl_Size freeSpace;
RINGBUFFER_ASSERT(ringPtr);
freeSpace = ringPtr->capacity - ringPtr->length;
if (freeSpace < srcLen) {
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 | * * Side effects: * Internal buffer is updated. * *------------------------------------------------------------------------ */ static Tcl_Size | | > | | | | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
*
* Side effects:
* Internal buffer is updated.
*
*------------------------------------------------------------------------
*/
static Tcl_Size
RingBufferOut(
RingBuffer *ringPtr,
char *dstPtr, /* Buffer for output data. May be NULL */
Tcl_Size dstCapacity, /* Size of buffer */
int partialCopyOk) /* If true, return what's available */
{
Tcl_Size leadLen;
RINGBUFFER_ASSERT(ringPtr);
if (dstCapacity > ringPtr->length) {
if (dstPtr && !partialCopyOk) {
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 |
RINGBUFFER_ASSERT(ringPtr);
return dstCapacity;
}
#ifndef NDEBUG
static int
| | > | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
RINGBUFFER_ASSERT(ringPtr);
return dstCapacity;
}
#ifndef NDEBUG
static int
RingBufferCheck(
const RingBuffer *ringPtr)
{
return (ringPtr->bufPtr != NULL && ringPtr->capacity == CONSOLE_BUFFER_SIZE
&& ringPtr->start < ringPtr->capacity
&& ringPtr->length <= ringPtr->capacity);
}
#endif
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
* See https://bugs.python.org/issue30237
* or https://github.com/microsoft/terminal/issues/12143
*/
nRead = (DWORD)-1;
result = ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL);
if (result) {
if ((nRead == 0 || nRead == (DWORD)-1)
| | | > | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
* See https://bugs.python.org/issue30237
* or https://github.com/microsoft/terminal/issues/12143
*/
nRead = (DWORD)-1;
result = ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL);
if (result) {
if ((nRead == 0 || nRead == (DWORD)-1)
&& GetLastError() == ERROR_OPERATION_ABORTED) {
nRead = 0;
}
*nCharsReadPtr = nRead;
return 0;
} else {
return GetLastError();
}
}
/*
*------------------------------------------------------------------------
*
* WriteConsoleChars --
*
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 | * Results: * None. * * Side effects: * As above. *------------------------------------------------------------------------ */ | > > | | | | 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 |
* Results:
* None.
*
* Side effects:
* As above.
*------------------------------------------------------------------------
*/
static void
NudgeWatchers(
HANDLE consoleHandle)
{
ConsoleChannelInfo *chanInfoPtr;
AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */
for (chanInfoPtr = gWatchingChannelList; chanInfoPtr;
chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
/*
* Notify channels interested in our handle AND that have
* a thread attached.
* No lock needed for chanInfoPtr. See ConsoleChannelInfo.
*/
if (chanInfoPtr->handle == consoleHandle
&& chanInfoPtr->threadId != NULL) {
Tcl_ThreadAlert(chanInfoPtr->threadId);
}
}
ReleaseSRWLockShared(&gConsoleLock);
}
/*
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
/*
* Walk the list of channels. See general comments for struct
* ConsoleChannelInfo with regard to locking and field access.
*/
AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */
for (chanInfoPtr = gWatchingChannelList; block && chanInfoPtr != NULL;
| | | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
/*
* Walk the list of channels. See general comments for struct
* ConsoleChannelInfo with regard to locking and field access.
*/
AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */
for (chanInfoPtr = gWatchingChannelList; block && chanInfoPtr != NULL;
chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
ConsoleHandleInfo *handleInfoPtr;
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr != NULL) {
AcquireSRWLockShared(&handleInfoPtr->lock);
/* Remember at most one of READABLE, WRITABLE set */
if (chanInfoPtr->watchMask & TCL_READABLE) {
if (RingBufferLength(&handleInfoPtr->buffer) > 0
|| handleInfoPtr->lastError != ERROR_SUCCESS) {
block = 0; /* Input data available */
}
} else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
/* TCL_WRITABLE */
block = 0; /* Output space available */
}
|
| ︙ | ︙ | |||
861 862 863 864 865 866 867 |
}
needEvent = 0;
AcquireSRWLockShared(&handleInfoPtr->lock);
/* Rememeber channel is read or write, never both */
if (chanInfoPtr->watchMask & TCL_READABLE) {
if (RingBufferLength(&handleInfoPtr->buffer) > 0
| | | 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 |
}
needEvent = 0;
AcquireSRWLockShared(&handleInfoPtr->lock);
/* Rememeber channel is read or write, never both */
if (chanInfoPtr->watchMask & TCL_READABLE) {
if (RingBufferLength(&handleInfoPtr->buffer) > 0
|| handleInfoPtr->lastError != ERROR_SUCCESS) {
needEvent = 1; /* Input data available or error/EOF */
}
/*
* TCL_READABLE watch means someone is looking out for data being
* available, let reader thread know. Note channel need not be
* ASYNC! (Bug [baa51423c2])
*/
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
if (needEvent) {
ConsoleEvent *evPtr = (ConsoleEvent *)Tcl_Alloc(sizeof(ConsoleEvent));
/* See note above loop why this can be accessed without locks */
chanInfoPtr->flags |= CONSOLE_EVENT_QUEUED;
chanInfoPtr->numRefs += 1; /* So it does not go away while event
| | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 |
if (needEvent) {
ConsoleEvent *evPtr = (ConsoleEvent *)Tcl_Alloc(sizeof(ConsoleEvent));
/* See note above loop why this can be accessed without locks */
chanInfoPtr->flags |= CONSOLE_EVENT_QUEUED;
chanInfoPtr->numRefs += 1; /* So it does not go away while event
* is in queue */
evPtr->header.proc = ConsoleEventProc;
evPtr->chanInfoPtr = chanInfoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
ReleaseSRWLockShared(&gConsoleLock);
|
| ︙ | ︙ | |||
912 913 914 915 916 917 918 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int ConsoleBlockModeProc( | | | 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 |
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
ConsoleBlockModeProc(
void *instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
/*
* Consoles on Windows can not be switched between blocking and
|
| ︙ | ︙ | |||
952 953 954 955 956 957 958 | * Closes the physical channel. * *---------------------------------------------------------------------- */ static int ConsoleCloseProc( | | | | | | | 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 |
* Closes the physical channel.
*
*----------------------------------------------------------------------
*/
static int
ConsoleCloseProc(
void *instanceData, /* Pointer to ConsoleChannelInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
ConsoleHandleInfo *handleInfoPtr;
int errorCode = 0;
ConsoleChannelInfo **nextPtrPtr;
int closeHandle;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Don't close the Win32 handle if the handle is a standard channel
* during the thread exit process. Otherwise, one thread may kill the
* stdio of another while exiting. Note an explicit close in script will
* still close the handle. That's historical behavior on all platforms.
*/
if (!TclInThreadExit()
|| ( (GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) {
closeHandle = 1;
} else {
closeHandle = 0;
}
AcquireSRWLockExclusive(&gConsoleLock);
/* Remove channel from watchers' list */
for (nextPtrPtr = &gWatchingChannelList; *nextPtrPtr != NULL;
nextPtrPtr = &(*nextPtrPtr)->nextWatchingChannelPtr) {
if (*nextPtrPtr == (ConsoleChannelInfo *) chanInfoPtr) {
*nextPtrPtr = (*nextPtrPtr)->nextWatchingChannelPtr;
break;
}
}
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
|
| ︙ | ︙ | |||
1071 1072 1073 1074 1075 1076 1077 | * Side effects: * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int ConsoleInputProc( | | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 |
* Side effects:
* Reads input from the actual channel.
*
*----------------------------------------------------------------------
*/
static int
ConsoleInputProc(
void *instanceData, /* Console state. */
char *bufPtr, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
ConsoleHandleInfo *handleInfoPtr;
|
| ︙ | ︙ | |||
1139 1140 1141 1142 1143 1144 1145 | *errorCode = EWOULDBLOCK; numRead = -1; break; } /* * Blocking read. Just get data from directly from console. There | | | > > > | | > > > > | > | < | < < | 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 |
*errorCode = EWOULDBLOCK;
numRead = -1;
break;
}
/*
* Blocking read. Just get data from directly from console. There
* is a small complication in that
* 1. The destination buffer should be WCHAR aligned.
* 2. We can only read even number of bytes (wide-character API).
* 3. Caller has large enough buffer (else length of line user can
* enter will be limited)
* If any condition is not met, we defer to the
* reader thread which handles these cases rather than dealing with
* them here (which is a little trickier than it might sound.)
*
* TODO - not clear this block is a useful optimization. bufSize by
* default is 4K which is < INPUT_BUFFER_SIZE and will rarely be
* increased on stdin.
*/
if ((1 & (size_t)bufPtr) == 0 /* aligned buffer */
&& (1 & bufSize) == 0 /* Even number of bytes */
&& bufSize > INPUT_BUFFER_SIZE) {
DWORD lastError;
Tcl_Size numChars;
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
lastError = ReadConsoleChars(chanInfoPtr->handle,
(WCHAR *)bufPtr, bufSize / sizeof(WCHAR), &numChars);
/* NOTE lock released so DON'T break. Return instead */
if (lastError != ERROR_SUCCESS) {
Tcl_WinConvertError(lastError);
*errorCode = Tcl_GetErrno();
return -1;
} else if (numChars > 0) {
/* Successfully read something. */
|
| ︙ | ︙ | |||
1182 1183 1184 1185 1186 1187 1188 | * Release the lock and sleep. Note that because the channel * holds a reference count on handleInfoPtr, it will not * be deallocated while the lock is released. */ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, | | < < | | 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 |
* Release the lock and sleep. Note that because the channel
* holds a reference count on handleInfoPtr, it will not
* be deallocated while the lock is released.
*/
handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV,
&handleInfoPtr->lock, INFINITE, 0)) {
Tcl_WinConvertError(GetLastError());
*errorCode = Tcl_GetErrno();
numRead = -1;
break;
}
/* Lock is reacquired, loop back to try again */
}
/* We read data. Ask for more if either async or watching for reads */
if ((chanInfoPtr->flags & CONSOLE_ASYNC)
|| (chanInfoPtr->watchMask & TCL_READABLE)) {
handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
}
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
return numRead;
}
|
| ︙ | ︙ | |||
1224 1225 1226 1227 1228 1229 1230 | * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int ConsoleOutputProc( | | | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 |
* Side effects:
* Writes output on the actual channel.
*
*----------------------------------------------------------------------
*/
static int
ConsoleOutputProc(
void *instanceData, /* Console state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
ConsoleHandleInfo *handleInfoPtr;
Tcl_Size numWritten;
|
| ︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 | * want to reorder output from within a thread * (3) when there are an odd number of bytes since WriteConsole * takes whole WCHARs * (4) when the pointer is not aligned on WCHAR * The ring buffer deals with cases (3) and (4). It would be harder * to duplicate that here. */ | | | | | < | < < | < < | > < | < | 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 |
* want to reorder output from within a thread
* (3) when there are an odd number of bytes since WriteConsole
* takes whole WCHARs
* (4) when the pointer is not aligned on WCHAR
* The ring buffer deals with cases (3) and (4). It would be harder
* to duplicate that here.
*/
if ((chanInfoPtr->flags & CONSOLE_ASYNC) /* Case (1) */
|| RingBufferLength(&handleInfoPtr->buffer) != 0 /* Case (2) */
|| (toWrite & 1) != 0 /* Case (3) */
|| (PTR2INT(buf) & 1) != 0) { /* Case (4) */
numWritten += RingBufferIn(&handleInfoPtr->buffer,
numWritten + buf, toWrite - numWritten, 1);
if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) {
/* All done or async, just accept whatever was written */
break;
}
/*
* Release the lock and sleep. Note that because the channel
* holds a reference count on handleInfoPtr, it will not
* be deallocated while the lock is released.
*/
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV,
&handleInfoPtr->lock, INFINITE, 0)) {
/* Report the error */
Tcl_WinConvertError(GetLastError());
*errorCode = Tcl_GetErrno();
numWritten = -1;
break;
}
} else {
/* Direct output */
DWORD winStatus;
HANDLE consoleHandle = handleInfoPtr->console;
/* Unlock before blocking in WriteConsole */
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
/* UNLOCKED so return, DON'T break out of loop as it will unlock
* again! */
winStatus = WriteConsoleChars(consoleHandle,
(WCHAR *)buf, toWrite / sizeof(WCHAR), &numWritten);
if (winStatus == ERROR_SUCCESS) {
return numWritten * sizeof(WCHAR);
} else {
Tcl_WinConvertError(winStatus);
*errorCode = Tcl_GetErrno();
return -1;
}
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 |
chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED;
/*
* Only handle the event if the Tcl channel has not gone away AND is
* still owned by this thread AND is still watching events.
*/
if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread()
| | | < | | | 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 |
chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED;
/*
* Only handle the event if the Tcl channel has not gone away AND is
* still owned by this thread AND is still watching events.
*/
if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread()
&& (chanInfoPtr->watchMask & (TCL_READABLE|TCL_WRITABLE))) {
ConsoleHandleInfo *handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr == NULL) {
/* Console was closed. EOF->read event only (not write) */
if (chanInfoPtr->watchMask & TCL_READABLE) {
mask = TCL_READABLE;
}
} else {
AcquireSRWLockShared(&handleInfoPtr->lock);
/* Remember at most one of READABLE, WRITABLE set */
if ((chanInfoPtr->watchMask & TCL_READABLE)
&& RingBufferLength(&handleInfoPtr->buffer)) {
mask = TCL_READABLE;
} else if ((chanInfoPtr->watchMask & TCL_WRITABLE)
&& RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
/* Generate write event space available */
mask = TCL_WRITABLE;
}
ReleaseSRWLockShared(&handleInfoPtr->lock);
}
}
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 | * None. * *---------------------------------------------------------------------- */ static void ConsoleWatchProc( | | | < | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 |
* None.
*
*----------------------------------------------------------------------
*/
static void
ConsoleWatchProc(
void *instanceData, /* Console state. */
int newMask) /* What events to watch for, one of
* TCL_READABLE, TCL_WRITABLE */
{
ConsoleChannelInfo **nextPtrPtr, *ptr;
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
int oldMask = chanInfoPtr->watchMask;
/*
* Since most of the work is handled by the background threads, we just
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 | gWatchingChannelList = chanInfoPtr; /* * For read channels, need to tell the console reader thread * that we are looking for data since it will not do reads until * it knows someone is awaiting. */ | | < | 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 |
gWatchingChannelList = chanInfoPtr;
/*
* For read channels, need to tell the console reader thread
* that we are looking for data since it will not do reads until
* it knows someone is awaiting.
*/
ConsoleHandleInfo *handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr) {
AcquireSRWLockExclusive(&handleInfoPtr->lock);
handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
}
ReleaseSRWLockExclusive(&gConsoleLock);
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 | * None. * *---------------------------------------------------------------------- */ static int ConsoleGetHandleProc( | | | | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
* None.
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetHandleProc(
void *instanceData, /* The console state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) {
return TCL_ERROR;
} else {
*handlePtr = chanInfoPtr->handle;
|
| ︙ | ︙ | |||
1570 1571 1572 1573 1574 1575 1576 | * * Side effects: * None. * *------------------------------------------------------------------------ */ static int | | > | | < | > | | 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 |
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static int
ConsoleDataAvailable(
HANDLE consoleHandle)
{
INPUT_RECORD input[10];
DWORD count;
DWORD i;
/*
* Need at least one keyboard event.
*/
if (PeekConsoleInputW(consoleHandle, input,
sizeof(input) / sizeof(input[0]), &count) == FALSE) {
return -1;
}
/*
* Even if windows size and mouse events are disabled, can still have
* events other than keyboard, like focus events. Look for at least one
* keydown event because a trailing LF keyup is always present from the
* last input. However, if our buffer is full, assume there is a key
* down somewhere in the unread buffer. I suppose we could expand the
* buffer but not worth...
*/
if (count == (sizeof(input)/sizeof(input[0]))) {
return 1;
}
for (i = 0; i < count; ++i) {
if (input[i].EventType == KEY_EVENT
&& input[i].Event.KeyEvent.bKeyDown) {
return 1;
}
}
return 0;
}
/*
|
| ︙ | ︙ | |||
1626 1627 1628 1629 1630 1631 1632 |
static DWORD WINAPI
ConsoleReaderThread(
LPVOID arg)
{
ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg;
ConsoleHandleInfo **iterator;
| < > > > | 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 |
static DWORD WINAPI
ConsoleReaderThread(
LPVOID arg)
{
ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg;
ConsoleHandleInfo **iterator;
Tcl_Size inputLen = 0;
Tcl_Size inputOffset = 0;
Tcl_Size lastReadSize = 0;
DWORD sleepTime;
char inputChars[INPUT_BUFFER_SIZE];
/*
* Keep looping until one of the following happens.
* - there are no more channels listening on the console
* - the console handle has been closed
*/
|
| ︙ | ︙ | |||
1662 1663 1664 1665 1666 1667 1668 |
if (inputLen > 0 || handleInfoPtr->lastError != 0) {
HANDLE consoleHandle;
if (inputLen > 0) {
/* Private buffer has data. Copy it over. */
Tcl_Size nStored;
assert((inputLen - inputOffset) > 0);
| < | < | | 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 |
if (inputLen > 0 || handleInfoPtr->lastError != 0) {
HANDLE consoleHandle;
if (inputLen > 0) {
/* Private buffer has data. Copy it over. */
Tcl_Size nStored;
assert((inputLen - inputOffset) > 0);
nStored = RingBufferIn(&handleInfoPtr->buffer,
inputOffset + inputChars, inputLen - inputOffset,
1);
inputOffset += nStored;
if (inputOffset == inputLen) {
/* Temp buffer now empty */
inputOffset = 0;
inputLen = 0;
}
} else {
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 | consoleHandle = handleInfoPtr->console; ReleaseSRWLockExclusive(&handleInfoPtr->lock); NudgeWatchers(consoleHandle); AcquireSRWLockExclusive(&handleInfoPtr->lock); /* * Loop back to recheck for exit conditions changes while the | | > > > | > > > > > | | | | > | | < < < | < | > > < | < < | | | 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 |
consoleHandle = handleInfoPtr->console;
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
NudgeWatchers(consoleHandle);
AcquireSRWLockExclusive(&handleInfoPtr->lock);
/*
* Loop back to recheck for exit conditions changes while the
* lock was not held.
*/
continue;
}
assert(inputLen == 0);
/*
* Read more data in two cases:
* 1. The previous read filled the buffer and there could be more
* data in the console internal *text* buffer. Note
* ConsolePendingInput (checked in ConsoleDataAvailable) will NOT
* show this. It holds input events not yet translated to text.
* 2. Tcl threads want more data AND there is data in the
* ConsolePendingInput buffer. The latter check necessary because
* we do not want to read ahead because the interp thread might
* change the read mode, e.g. turning off echo for password
* input. So only do so if at least one interpreter has requested
* data.
*/
if (lastReadSize == sizeof(inputChars)
|| ((handleInfoPtr->flags & CONSOLE_DATA_AWAITED)
&& ConsoleDataAvailable(handleInfoPtr->console))) {
DWORD error;
/* Do not hold the lock while blocked in console */
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
error = ReadConsoleChars(handleInfoPtr->console,
(WCHAR *)inputChars, sizeof(inputChars) / sizeof(WCHAR),
&inputLen);
AcquireSRWLockExclusive(&handleInfoPtr->lock);
if (error == 0) {
inputLen *= sizeof(WCHAR);
lastReadSize = inputLen;
} else {
/*
* We only store the last error. It is up to channel
* handlers whether to close or not in case of errors.
*/
lastReadSize = 0;
handleInfoPtr->lastError = error;
if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) {
handleInfoPtr->console = INVALID_HANDLE_VALUE;
}
}
} else {
/*
* Either no one was asking for data, or no data was available.
* In the former case, wait until someone wakes us asking for
* data. In the latter case, there is no alternative but to
* poll since ReadConsole does not support async operation.
* So sleep for a short while and loop back to retry.
*/
sleepTime =
handleInfoPtr->flags & CONSOLE_DATA_AWAITED ? 50 : INFINITE;
SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV,
&handleInfoPtr->lock, sleepTime, 0);
}
/* Loop again to check for exit or wait for readers to wake us */
}
/*
* Exiting:
* - remove the console from global list
* - close the handle if still valid
* - release the structure
* Note there is not need to check for any watchers because we only
* exit when there are no channels open to this console.
*/
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */
for (iterator = &gConsoleHandleInfoList; *iterator;
iterator = &(*iterator)->nextPtr) {
if (*iterator == handleInfoPtr) {
*iterator = handleInfoPtr->nextPtr;
break;
}
}
ReleaseSRWLockExclusive(&gConsoleLock);
/* No need for relocking - no other thread should have access to it now */
RingBufferClear(&handleInfoPtr->buffer);
if (handleInfoPtr->console != INVALID_HANDLE_VALUE
&& handleInfoPtr->lastError != ERROR_INVALID_HANDLE) {
SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode);
/*
* NOTE: we do not call CloseHandle(handleInfoPtr->console) here.
* As per the GetStdHandle documentation, it need not be closed.
* Other components may be directly using it. Note however that
* an explicit chan close script command does close the handle
* for all threads.
|
| ︙ | ︙ | |||
1817 1818 1819 1820 1821 1822 1823 | * * Side effects: * Signals the main thread when an output operation is completed. * *---------------------------------------------------------------------- */ static DWORD WINAPI | | > | 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 |
*
* Side effects:
* Signals the main thread when an output operation is completed.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
ConsoleWriterThread(
LPVOID arg)
{
ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg;
ConsoleHandleInfo **iterator;
BOOL success;
Tcl_Size numBytes;
/*
* This buffer size has no relation really with the size of the shared
|
| ︙ | ︙ | |||
1870 1871 1872 1873 1874 1875 1876 | * and no buffered output. */ break; } /* Wake up any threads waiting synchronously. */ WakeConditionVariable(&handleInfoPtr->interpThreadCV); success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, | | < < | 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 |
* and no buffered output.
*/
break;
}
/* Wake up any threads waiting synchronously. */
WakeConditionVariable(&handleInfoPtr->interpThreadCV);
success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV,
&handleInfoPtr->lock, INFINITE, 0);
/* Note: lock has been acquired again! */
if (!success && GetLastError() != ERROR_TIMEOUT) {
/* TODO - what can be done? Should not happen */
/* For now keep going */
}
continue;
}
|
| ︙ | ︙ | |||
1896 1897 1898 1899 1900 1901 1902 |
WakeConditionVariable(&handleInfoPtr->interpThreadCV);
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
offset = 0;
while (numBytes > 0) {
Tcl_Size numWChars = numBytes / sizeof(WCHAR);
DWORD status;
status = WriteConsoleChars(handleInfoPtr->console,
| | < < | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 |
WakeConditionVariable(&handleInfoPtr->interpThreadCV);
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
offset = 0;
while (numBytes > 0) {
Tcl_Size numWChars = numBytes / sizeof(WCHAR);
DWORD status;
status = WriteConsoleChars(handleInfoPtr->console,
(WCHAR *)(offset + buffer), numWChars, &numWChars);
if (status != 0) {
/* Only overwrite if no previous error */
if (handleInfoPtr->lastError == 0) {
handleInfoPtr->lastError = status;
}
if (status == ERROR_INVALID_HANDLE) {
handleInfoPtr->console = INVALID_HANDLE_VALUE;
|
| ︙ | ︙ | |||
1943 1944 1945 1946 1947 1948 1949 |
* Other components may be directly using it. Note however that
* an explicit chan close script command does close the handle
* for all threads.
*/
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */
for (iterator = &gConsoleHandleInfoList; *iterator;
| | | 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 |
* Other components may be directly using it. Note however that
* an explicit chan close script command does close the handle
* for all threads.
*/
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */
for (iterator = &gConsoleHandleInfoList; *iterator;
iterator = &(*iterator)->nextPtr) {
if (*iterator == handleInfoPtr) {
*iterator = handleInfoPtr->nextPtr;
break;
}
}
ReleaseSRWLockExclusive(&gConsoleLock);
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 |
AllocateConsoleHandleInfo(
HANDLE consoleHandle,
int permissions) /* TCL_READABLE or TCL_WRITABLE */
{
ConsoleHandleInfo *handleInfoPtr;
DWORD consoleMode;
| < < | 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 |
AllocateConsoleHandleInfo(
HANDLE consoleHandle,
int permissions) /* TCL_READABLE or TCL_WRITABLE */
{
ConsoleHandleInfo *handleInfoPtr;
DWORD consoleMode;
handleInfoPtr = (ConsoleHandleInfo *)Tcl_Alloc(sizeof(*handleInfoPtr));
memset(handleInfoPtr, 0, sizeof(*handleInfoPtr));
handleInfoPtr->console = consoleHandle;
InitializeSRWLock(&handleInfoPtr->lock);
InitializeConditionVariable(&handleInfoPtr->consoleThreadCV);
InitializeConditionVariable(&handleInfoPtr->interpThreadCV);
RingBufferInit(&handleInfoPtr->buffer, CONSOLE_BUFFER_SIZE);
handleInfoPtr->lastError = 0;
|
| ︙ | ︙ | |||
2053 2054 2055 2056 2057 2058 2059 | * * Side effects: * None. * *------------------------------------------------------------------------ */ static ConsoleHandleInfo * | > | | 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 |
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static ConsoleHandleInfo *
FindConsoleInfo(
const ConsoleChannelInfo *chanInfoPtr)
{
ConsoleHandleInfo *handleInfoPtr;
for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) {
if (handleInfoPtr->console == chanInfoPtr->handle) {
return handleInfoPtr;
}
}
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 |
mode = chanInfoPtr->initMode;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
| | | 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 |
mode = chanInfoPtr->initMode;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", (char *)NULL);
}
return TCL_ERROR;
}
if (SetConsoleMode(chanInfoPtr->handle, mode) == 0) {
Tcl_WinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
2397 2398 2399 2400 2401 2402 2403 |
}
if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) {
CONSOLE_SCREEN_BUFFER_INFO consoleInfo;
valid = 1;
if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle,
| | | < | | | < | < < | 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 |
}
if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) {
CONSOLE_SCREEN_BUFFER_INFO consoleInfo;
valid = 1;
if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle,
&consoleInfo)) {
Tcl_WinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console size: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
Tcl_DStringStartSublist(dsPtr);
snprintf(buf, sizeof(buf), "%d",
consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1);
Tcl_DStringAppendElement(dsPtr, buf);
snprintf(buf, sizeof(buf), "%d",
consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1);
Tcl_DStringAppendElement(dsPtr, buf);
Tcl_DStringEndSublist(dsPtr);
}
}
if (valid) {
return TCL_OK;
}
if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
return Tcl_BadChannelOption(interp, optionName, "inputmode");
} else {
|
| ︙ | ︙ |
Changes to win/tclWinDde.c.
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
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));
| | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
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", (char *)NULL);
result = TCL_ERROR;
}
if (riPtr->handlerPtr != NULL) {
/*
* Add the dde request data to the handler proc list.
*/
|
| ︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 | Tcl_DString dString; Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(name, wcslen(name), &dString); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no registered server named \"%s\"", Tcl_DStringValue(&dString))); Tcl_DStringFree(&dString); | | | 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 |
Tcl_DString dString;
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(name, wcslen(name), &dString);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no registered server named \"%s\"", Tcl_DStringValue(&dString)));
Tcl_DStringFree(&dString);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (char *)NULL);
}
return TCL_ERROR;
}
*ddeConvPtr = ddeConv;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1277 1278 1279 1280 1281 1282 1283 |
break;
default:
errorMessage = "dde command failed";
errorCode = "FAILED";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
| | | 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 |
break;
default:
errorMessage = "dde command failed";
errorCode = "FAILED";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, (char *)NULL);
}
/*
*----------------------------------------------------------------------
*
* DdeObjCmd --
*
|
| ︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 |
enum DdeSrvOptions {
DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
};
static const char *const ddeExecOptions[] = {
"-async", "-binary", NULL
};
enum DdeExecOptions {
| | | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 |
enum DdeSrvOptions {
DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
};
static const char *const ddeExecOptions[] = {
"-async", "-binary", NULL
};
enum DdeExecOptions {
DDE_EXEC_ASYNC, DDE_EXEC_BINARY
};
static const char *const ddeEvalOptions[] = {
"-async", NULL
};
static const char *const ddeReqOptions[] = {
"-binary", NULL
};
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
}
if (dataLength + 1 < 2) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
Tcl_DStringFree(&dsBuf);
| | | 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 |
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", (char *)NULL);
result = TCL_ERROR;
break;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 |
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));
| | | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 |
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", (char *)NULL);
result = TCL_ERROR;
goto cleanup;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
|
| ︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 |
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));
| | | 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 |
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", (char *)NULL);
result = TCL_ERROR;
goto cleanup;
}
Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString = (BYTE *)
Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length);
|
| ︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 |
case DDE_EVAL: {
RegisteredInterp *riPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (serviceName == NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("invalid service name \"\"", -1));
| | | 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 |
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", (char *)NULL);
result = TCL_ERROR;
goto cleanup;
}
objc -= firstArg + 1;
objv += firstArg + 1;
|
| ︙ | ︙ | |||
1783 1784 1785 1786 1787 1788 1789 |
*/
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",
| | | 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 |
*/
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",
(char *)NULL);
result = TCL_ERROR;
}
if (result == TCL_OK) {
if (objc == 1) {
objPtr = objv[0];
} else {
|
| ︙ | ︙ | |||
1848 1849 1850 1851 1852 1853 1854 |
* poll it for a result.
*/
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
invalidServerResponse:
Tcl_SetObjResult(interp,
Tcl_NewStringObj("invalid data returned from server", -1));
| | | 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 |
* 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", (char *)NULL);
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_DStringInit(&dsBuf);
|
| ︙ | ︙ |
Changes to win/tclWinError.c.
| ︙ | ︙ | |||
377 378 379 380 381 382 383 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE void
tclWinDebugPanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 1024
va_list argList;
va_start(argList, format);
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 |
WIN_SHORTNAME_ATTRIBUTE,
WIN_SYSTEM_ATTRIBUTE
};
static const int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
| < | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
WIN_SHORTNAME_ATTRIBUTE,
WIN_SYSTEM_ATTRIBUTE
};
static const int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
const char *const tclpFileAttrStrings[] = {
"-archive", "-hidden", "-longname", "-readonly",
"-shortname", "-system", NULL
};
const TclFileAttrProcs tclpFileAttrProcs[] = {
{GetWinFileAttributes, SetWinFileAttributes},
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
| | < | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
if (MoveFileW(nativeSrc, nativeDst) != FALSE) {
return TCL_OK;
}
/*
* Some new error has occurred. Don't know what it could
* be, but report this one.
*/
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 |
}
}
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
SetFileAttributesW(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
| | < | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 |
}
}
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
SetFileAttributesW(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
if (CopyFileW(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
}
/*
* Still can't copy onto dst. Return that error, and restore
* attributes of dst.
*/
|
| ︙ | ︙ | |||
790 791 792 793 794 795 796 |
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
int res = SetFileAttributesW(path,
attr & ~((DWORD) FILE_ATTRIBUTE_READONLY));
| < | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 |
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
int res = SetFileAttributesW(path,
attr & ~((DWORD) FILE_ATTRIBUTE_READONLY));
if ((res != 0) && (DeleteFileW(path) != FALSE)) {
return TCL_OK;
}
Tcl_WinConvertError(GetLastError());
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
|
| ︙ | ︙ | |||
926 927 928 929 930 931 932 |
if (ret != TCL_OK) {
if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) {
*errorPtr = srcPathPtr;
} else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
*errorPtr = destPathPtr;
} else {
| | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 |
if (ret != TCL_OK) {
if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) {
*errorPtr = srcPathPtr;
} else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
*errorPtr = destPathPtr;
} else {
*errorPtr = Tcl_DStringToObj(&ds);
}
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
return ret;
}
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 |
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
| | < | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 |
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if (SetFileAttributesW(nativePath, attr) == FALSE) {
goto end;
}
if (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
Tcl_WinConvertError(GetLastError());
SetFileAttributesW(nativePath,
|
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 |
end:
if (errorPtr != NULL) {
char *p;
Tcl_DStringInit(errorPtr);
p = Tcl_WCharToUtfDString(nativePath, TCL_INDEX_NONE, errorPtr);
for (; *p; ++p) {
| | > > | 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
end:
if (errorPtr != NULL) {
char *p;
Tcl_DStringInit(errorPtr);
p = Tcl_WCharToUtfDString(nativePath, TCL_INDEX_NONE, errorPtr);
for (; *p; ++p) {
if (*p == '\\') {
*p = '/';
}
}
}
return TCL_ERROR;
}
static int
|
| ︙ | ︙ | |||
1377 1378 1379 1380 1381 1382 1383 |
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(nativeDst) == TCL_OK) {
DWORD attr = GetFileAttributesW(nativeSrc);
| | < | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 |
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(nativeDst) == TCL_OK) {
DWORD attr = GetFileAttributesW(nativeSrc);
if (SetFileAttributesW(nativeDst, attr) != FALSE) {
return TCL_OK;
}
Tcl_WinConvertError(GetLastError());
}
break;
case DOTREE_POSTD:
return TCL_OK;
|
| ︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 | * root volumes (drives) formatted as NTFS are declared hidden when * they are not (and cannot be). * * We test for, and fix that case, here. */ Tcl_Size len; | | | 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 |
* root volumes (drives) formatted as NTFS are declared hidden when
* they are not (and cannot be).
*
* We test for, and fix that case, here.
*/
Tcl_Size len;
const char *str = TclGetStringFromObj(fileName, &len);
if (len < 4) {
if (len == 0) {
/*
* Not sure if this is possible, but we pass it on anyway.
*/
} else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
| | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
pathv = TclGetStringFromObj(elt, &length);
if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
/*
* Handle "/", "//machine/export", "c:/", "." or ".." by just
* copying the string literally. Uppercase the drive letter, just
* because it looks better under Windows to do so.
*/
|
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 | Tcl_IncrRefCount(tempPath); /* * We'd like to call Tcl_FSGetNativePath(tempPath) but that is * likely to lead to infinite loops. */ | | | 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 |
Tcl_IncrRefCount(tempPath);
/*
* We'd like to call Tcl_FSGetNativePath(tempPath) but that is
* likely to lead to infinite loops.
*/
tempString = TclGetStringFromObj(tempPath, &length);
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(tempString, length, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFileW(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFileW() doesn't like root directories. We would
|
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 | * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); | | | | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 |
* fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
*/
Tcl_DStringInit(&dsTemp);
Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp);
Tcl_DStringFree(&ds);
tempPath = Tcl_DStringToObj(&dsTemp);
Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
FindClose(handle);
}
}
*attributePtrPtr = Tcl_FSJoinPath(splitPath, TCL_INDEX_NONE);
if (splitPath != NULL) {
|
| ︙ | ︙ | |||
1988 1989 1990 1991 1992 1993 1994 |
/*
* Build the path in writable memory from the user-supplied pieces and
* some defaults. First, the parent temporary directory.
*/
if (dirObj) {
| | | | | 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 |
/*
* Build the path in writable memory from the user-supplied pieces and
* some defaults. First, the parent temporary directory.
*/
if (dirObj) {
TclGetString(dirObj);
if (dirObj->length < 1) {
goto useSystemTemp;
}
Tcl_DStringInit(&base);
Tcl_UtfToWCharDString(TclGetString(dirObj), TCL_INDEX_NONE, &base);
if (dirObj->bytes[dirObj->length - 1] != '\\') {
Tcl_UtfToWCharDString("\\", TCL_INDEX_NONE, &base);
}
} else {
useSystemTemp:
Tcl_DStringInit(&base);
Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
}
/*
* Next, the base of the directory name.
*/
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
#define SUFFIX_LENGTH 8
if (basenameObj) {
Tcl_UtfToWCharDString(TclGetString(basenameObj), TCL_INDEX_NONE, &base);
} else {
Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, TCL_INDEX_NONE, &base);
}
Tcl_UtfToWCharDString("_", TCL_INDEX_NONE, &base);
/*
* Now we keep on trying random suffixes until we get one that works
|
| ︙ | ︙ |
Changes to win/tclWinFile.c.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
WCHAR dummyBuf[MAX_PATH * 3];
} DUMMY_REPARSE_BUFFER;
/*
* Other typedefs required by this code.
*/
| | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
WCHAR dummyBuf[MAX_PATH * 3];
} DUMMY_REPARSE_BUFFER;
/*
* Other typedefs required by this code.
*/
static __time64_t ToCTime(FILETIME fileTime);
static void FromCTime(__time64_t posixTime, FILETIME *fileTime);
/*
* Declarations for local functions defined in this file:
*/
static int NativeAccess(const WCHAR *path, int mode);
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 | * The computed path is stored. * *--------------------------------------------------------------------------- */ void TclpFindExecutable( | | < < | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
* The computed path is stored.
*
*---------------------------------------------------------------------------
*/
void
TclpFindExecutable(
TCL_UNUSED(const char *))
{
WCHAR wName[MAX_PATH];
char name[MAX_PATH * 3];
GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR));
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
TclSetObjNameOfExecutable(Tcl_NewStringObj(name, TCL_INDEX_NONE), NULL);
}
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 | /* * Match a single file directly. */ DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; Tcl_Size len = 0; | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
/*
* Match a single file directly.
*/
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
Tcl_Size len = 0;
const char *str = TclGetStringFromObj(norm, &len);
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesExW(native,
GetFileExInfoStandard, &data) != TRUE) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 |
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return TCL_OK;
}
attr = GetFileAttributesW(native);
if ((attr == INVALID_FILE_ATTRIBUTES)
| | | | 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 |
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return TCL_OK;
}
attr = GetFileAttributesW(native);
if ((attr == INVALID_FILE_ATTRIBUTES)
|| ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
return TCL_OK;
}
/*
* Build up the directory name for searching, including a trailing
* directory separator.
*/
Tcl_DStringInit(&dsOrig);
dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
|
| ︙ | ︙ | |||
1434 1435 1436 1437 1438 1439 1440 |
Tcl_DStringInit(bufferPtr);
wDomain = NULL;
domain = Tcl_UtfFindFirst(name, '@');
if (domain == NULL) {
const char *ptr;
| | | | | | | | | | | | | | | | | | | 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 |
Tcl_DStringInit(bufferPtr);
wDomain = NULL;
domain = Tcl_UtfFindFirst(name, '@');
if (domain == NULL) {
const char *ptr;
/*
* Treat the current user as a special case because the general case
* below does not properly retrieve the path. The NetUserGetInfo
* call returns an empty path and the code defaults to the user's
* name in the profiles directory. On modern Windows systems, this
* is generally wrong as when the account is a Microsoft account,
* for example abcdefghi@outlook.com, the directory name is
* abcde and not abcdefghi.
*
* Note we could have just used env(USERPROFILE) here but
* the intent is to retrieve (as on Unix) the system's view
* of the home irrespective of environment settings of HOME
* and USERPROFILE.
*
* Fixing this for the general user needs more investigating but
* at least for the current user we can use a direct call.
*/
ptr = TclpGetUserName(&ds);
if (ptr != NULL && strcasecmp(name, ptr) == 0) {
HANDLE hProcess;
WCHAR buf[MAX_PATH];
DWORD nChars = sizeof(buf) / sizeof(buf[0]);
/* Sadly GetCurrentProcessToken not in Win 7 so slightly longer */
hProcess = GetCurrentProcess(); /* Need not be closed */
|
| ︙ | ︙ | |||
1531 1532 1533 1534 1535 1536 1537 |
*/
for (i = 0; i < size; ++i) {
if (result[i] == '\\') {
result[i] = '/';
}
}
| | | | 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 |
*/
for (i = 0; i < size; ++i) {
if (result[i] == '\\') {
result[i] = '/';
}
}
NetApiBufferFree((void *)uiPtr);
}
Tcl_DStringFree(&ds);
}
if (wDomain != NULL) {
NetApiBufferFree((void *)wDomain);
}
return result;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2050 2051 2052 2053 2054 2055 2056 |
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (fileHandle != INVALID_HANDLE_VALUE) {
BY_HANDLE_FILE_INFORMATION data;
if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
| | | | | | | | | | | | | | | | | | | 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 |
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (fileHandle != INVALID_HANDLE_VALUE) {
BY_HANDLE_FILE_INFORMATION data;
if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
fileType = GetFileType(fileHandle);
CloseHandle(fileHandle);
if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
Tcl_SetErrno(ENOENT);
return -1;
}
/*
* Mock up the expected structure
*/
memset(&data, 0, sizeof(data));
statPtr->st_atime = 0;
statPtr->st_mtime = 0;
statPtr->st_ctime = 0;
} else {
CloseHandle(fileHandle);
statPtr->st_atime = ToCTime(data.ftLastAccessTime);
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.ftCreationTime);
}
attr = data.dwFileAttributes;
statPtr->st_size = ((long long) data.nFileSizeLow) |
(((long long) data.nFileSizeHigh) << 32);
/*
* On Unix, for directories, nlink apparently depends on the number of
* files in the directory. We could calculate that, but it would be a
|
| ︙ | ︙ | |||
2130 2131 2132 2133 2134 2135 2136 |
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.ftCreationTime);
}
dev = NativeDev(nativePath);
mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));
if (fileType == FILE_TYPE_CHAR) {
| | | | | | 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 |
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.ftCreationTime);
}
dev = NativeDev(nativePath);
mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));
if (fileType == FILE_TYPE_CHAR) {
mode &= ~S_IFMT;
mode |= S_IFCHR;
} else if (fileType == FILE_TYPE_DISK) {
mode &= ~S_IFMT;
mode |= S_IFBLK;
}
statPtr->st_dev = (dev_t) dev;
statPtr->st_ino = inode;
statPtr->st_mode = mode;
statPtr->st_nlink = nlink;
statPtr->st_uid = 0;
|
| ︙ | ︙ | |||
2746 2747 2748 2749 2750 2751 2752 | currentPathEndPosition++; #ifdef TclNORM_LONG_PATH /* * Convert the entire known path to long form. */ | < | | | | | | | | | | | | | | | | | < | 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 |
currentPathEndPosition++;
#ifdef TclNORM_LONG_PATH
/*
* Convert the entire known path to long form.
*/
WCHAR wpath[MAX_PATH];
const WCHAR *nativePath;
DWORD wpathlen;
Tcl_DStringInit(&ds);
nativePath =
Tcl_UtfToWCharDString(path, lastValidPathEnd - path, &ds);
wpathlen = GetLongPathNameProc(nativePath,
(WCHAR *) wpath, MAX_PATH);
/*
* We have to make the drive letter uppercase.
*/
if (wpath[0] >= 'a') {
wpath[0] -= ('a' - 'A');
}
Tcl_DStringAppend(&dsNorm, (const char *) wpath,
wpathlen * sizeof(WCHAR));
Tcl_DStringFree(&ds);
#endif /* TclNORM_LONG_PATH */
}
/*
* Common code path for all Windows platforms.
*/
|
| ︙ | ︙ | |||
2797 2798 2799 2800 2801 2802 2803 | Tcl_Obj *tmpPathPtr; Tcl_Size len; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE); | | | 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 |
Tcl_Obj *tmpPathPtr;
Tcl_Size len;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE);
path = TclGetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
Tcl_DecrRefCount(tmpPathPtr);
} else {
/*
* End of string was reached above.
*/
|
| ︙ | ︙ | |||
2882 2883 2884 2885 2886 2887 2888 |
} else {
/*
* Path of form C:foo/bar, but this only makes sense if the cwd is
* also on drive C.
*/
Tcl_Size cwdLen;
| | | 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 |
} else {
/*
* Path of form C:foo/bar, but this only makes sense if the cwd is
* also on drive C.
*/
Tcl_Size cwdLen;
const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen);
char drive_cur = path[0];
if (drive_cur >= 'a') {
drive_cur -= ('a' - 'A');
}
if (drive[0] == drive_cur) {
absolutePath = Tcl_DuplicateObj(useThisCwd);
|
| ︙ | ︙ | |||
3021 3022 3023 3024 3025 3026 3027 |
{
WCHAR *nativePathPtr = NULL;
const char *str;
Tcl_Obj *validPathPtr;
Tcl_Size len;
WCHAR *wp;
| | | | 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 |
{
WCHAR *nativePathPtr = NULL;
const char *str;
Tcl_Obj *validPathPtr;
Tcl_Size len;
WCHAR *wp;
if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) {
/*
* The cwd is native (or path is absolute), use the translated path
* without worrying about normalization (this will also usually be
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
|
| ︙ | ︙ | |||
3055 3056 3057 3058 3059 3060 3061 |
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
| | | 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 |
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetStringFromObj(validPathPtr, &len);
if (strlen(str) != (size_t)len) {
/*
* String contains NUL-bytes. This is invalid.
*/
goto done;
|
| ︙ | ︙ | |||
3088 3089 3090 3091 3092 3093 3094 |
/*
* Overallocate 6 chars, making some room for extended paths
*/
wp = nativePathPtr = (WCHAR *)Tcl_Alloc((len + 6) * sizeof(WCHAR));
if (nativePathPtr==0) {
| | | 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 |
/*
* Overallocate 6 chars, making some room for extended paths
*/
wp = nativePathPtr = (WCHAR *)Tcl_Alloc((len + 6) * sizeof(WCHAR));
if (nativePathPtr==0) {
goto done;
}
MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
len + 2);
nativePathPtr[len] = 0;
/*
* If path starts with "//?/" or "\\?\" (extended path), translate any
|
| ︙ | ︙ | |||
3142 3143 3144 3145 3146 3147 3148 |
/*
* In the remainder of the path, translate invalid characters to
* characters in the Unicode private use area.
*/
while (*wp != '\0') {
| | | 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 |
/*
* In the remainder of the path, translate invalid characters to
* characters in the Unicode private use area.
*/
while (*wp != '\0') {
if ((*wp < ' ') || wcschr(L"\"*<>?|", *wp)) {
*wp |= 0xF000;
} else if (*wp == '/') {
*wp = '\\';
}
++wp;
}
|
| ︙ | ︙ | |||
3278 3279 3280 3281 3282 3283 3284 |
int owned = 0;
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT,
OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
&secd) != ERROR_SUCCESS) {
| | | | | | | | | | | | | | | | 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 |
int owned = 0;
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT,
OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
&secd) != ERROR_SUCCESS) {
/*
* Either not a file, or we do not have access to it in which case we
* are in all likelihood not the owner.
*/
return 0;
}
/*
* Getting the current process SID is a multi-step process. We make the
* assumption that if a call fails, this process is so underprivileged it
* could not possibly own anything. Normally a process can *always* look
* up its own token.
*/
if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
/*
* Find out how big the buffer needs to be.
*/
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
buf = (LPBYTE)Tcl_Alloc(bufsz);
if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
}
}
CloseHandle(token);
}
/*
* Free allocations and be done.
*/
if (secd) {
LocalFree(secd); /* Also frees ownerSid */
}
if (buf) {
Tcl_Free(buf);
}
return (owned != 0); /* Convert non-0 to 1 */
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
* The following arrays contain the human readable strings for the
* processor values.
*/
#define NUMPROCESSORS 15
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
| | > > > > > > > > > < < < < < | 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 |
* The following arrays contain the human readable strings for the
* processor values.
*/
#define NUMPROCESSORS 15
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64",
"ia32_on_arm64"
};
/*
* Forward declarations
*/
static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir;
static TclInitProcessGlobalValueProc InitializeSourceLibraryDir;
static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib);
/*
* The default directory in which the init.tcl file is expected to be found.
*/
static ProcessGlobalValue defaultLibraryDir =
{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
static ProcessGlobalValue sourceLibraryDir =
{0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL};
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
* Initialize all the platform-dependent things like signals,
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
| | | | | 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 |
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = TclGetStringFromObj(pathPtr, &length);
*lengthPtr = length++;
*valuePtr = (char *)Tcl_Alloc(length);
memcpy(*valuePtr, bytes, length);
Tcl_DecrRefCount(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
* AppendEnvironment --
*
* Append the value of the TCL_LIBRARY environment variable onto the path
* pointer. If the env variable points to another version of tcl (e.g.
* "tcl8.6") also append the path to this version (e.g.,
* "tcl8.6/../tcl9.0")
*
* Results:
* None.
*
* Side effects:
* None.
*
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
Tcl_Obj *objPtr;
Tcl_DString ds;
const char **pathv;
char *shortlib;
/*
* The shortlib value needs to be the tail component of the lib path. For
| | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
Tcl_Obj *objPtr;
Tcl_DString ds;
const char **pathv;
char *shortlib;
/*
* The shortlib value needs to be the tail component of the lib path. For
* example, "lib/tcl9.0" -> "tcl9.0" while "usr/share/tcl9.0" -> "tcl9.0".
*/
for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) {
if (*shortlib == '/') {
if ((size_t)(shortlib - lib) == strlen(lib) - 1) {
Tcl_Panic("last character in lib cannot be '/'");
}
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
{
UINT acp = GetACP();
Tcl_DStringInit(bufPtr);
if (acp == CP_UTF8) {
Tcl_DStringAppend(bufPtr, "utf-8", 5);
} else {
| | | > | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
{
UINT acp = GetACP();
Tcl_DStringInit(bufPtr);
if (acp == CP_UTF8) {
Tcl_DStringAppend(bufPtr, "utf-8", 5);
} else {
Tcl_DStringSetLength(bufPtr, 2 + TCL_INTEGER_SPACE);
snprintf(Tcl_DStringValue(bufPtr), 2 + TCL_INTEGER_SPACE, "cp%d",
GetACP());
Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
}
return Tcl_DStringValue(bufPtr);
}
const char *
TclpGetUserName(
|
| ︙ | ︙ | |||
448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
*----------------------------------------------------------------------
*/
void
TclpSetVariables(
Tcl_Interp *interp) /* Interp to initialize. */
{
const char *ptr;
char buffer[TCL_INTEGER_SPACE * 2];
union {
SYSTEM_INFO info;
OemId oemId;
} sys;
static OSVERSIONINFOW osInfo;
static int osInfoInitialized = 0;
Tcl_DString ds;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandleW(L"NTDLL");
| > | | > | | < | > | 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 |
*----------------------------------------------------------------------
*/
void
TclpSetVariables(
Tcl_Interp *interp) /* Interp to initialize. */
{
typedef int(__stdcall getVersionProc)(void *);
const char *ptr;
char buffer[TCL_INTEGER_SPACE * 2];
union {
SYSTEM_INFO info;
OemId oemId;
} sys;
static OSVERSIONINFOW osInfo;
static int osInfoInitialized = 0;
Tcl_DString ds;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandleW(L"NTDLL");
getVersionProc *getVersion = (getVersionProc *) (void *)
GetProcAddress(handle, "RtlGetVersion");
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
if (!getVersion || getVersion(&osInfo)) {
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
}
GetSystemInfo(&sys.info);
/*
* Define the tcl_platform array.
*/
Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY);
if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) {
osInfo.dwMajorVersion = 11;
}
snprintf(buffer, sizeof(buffer), "%ld.%ld",
osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sys.oemId.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 |
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
} else {
| | | | | | | | | | | 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 |
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
} else {
/* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */
ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY);
if (ptr != NULL && ptr[0]) {
Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY);
} else {
/* Last resort */
Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
}
}
}
/*
* Initialize the user name from the environment first, since this is much
* faster than asking the system.
* Note: cchUserNameLen is number of characters including nul terminator.
*/
ptr = TclpGetUserName(&ds);
Tcl_SetVar2(interp, "tcl_platform", "user", ptr ? ptr : "",
TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* Define what the platform PATH separator is. [TIP #315]
*/
Tcl_SetVar2(interp, "tcl_platform", "pathSeparator", ";", TCL_GLOBAL_ONLY);
}
/*
*----------------------------------------------------------------------
*
* TclpFindVariable --
*
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
const char *name, /* Name of desired environment variable
* (UTF-8). */
Tcl_Size *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
| | | < < | | 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 |
const char *name, /* Name of desired environment variable
* (UTF-8). */
Tcl_Size *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
Tcl_Size i, length, result = TCL_INDEX_NONE;
const WCHAR *env;
const char *p1, *p2;
char *envUpper, *nameUpper;
Tcl_DString envString;
/*
* Convert the name to all upper case for the case insensitive comparison.
*/
length = strlen(name);
nameUpper = (char *)Tcl_Alloc(length + 1);
memcpy(nameUpper, name, length+1);
Tcl_UtfToUpper(nameUpper);
Tcl_DStringInit(&envString);
for (i = 0, env = _wenviron[i]; env != NULL; i++, env = _wenviron[i]) {
/*
* Chop the env string off after the equal sign, then Convert the name
* to all upper case, so we do not have to convert all the characters
* after the equal sign.
*/
Tcl_DStringInit(&envString);
envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = p1 - envUpper;
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
|
| ︙ | ︙ |
Changes to win/tclWinInt.h.
| ︙ | ︙ | |||
71 72 73 74 75 76 77 |
typedef struct TclPipeThreadInfo {
HANDLE evControl; /* Auto-reset event used by the main thread to
* signal when the pipe thread should attempt
* to do read/write operation. Additionally
* used as signal to stop (state set to -1) */
volatile LONG state; /* Indicates current state of the thread */
| | < | | | | | | | | > | > | > | 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 |
typedef struct TclPipeThreadInfo {
HANDLE evControl; /* Auto-reset event used by the main thread to
* signal when the pipe thread should attempt
* to do read/write operation. Additionally
* used as signal to stop (state set to -1) */
volatile LONG state; /* Indicates current state of the thread */
void *clientData; /* Referenced data of the main thread */
HANDLE evWakeUp; /* Optional wake-up event worker set by shutdown */
} TclPipeThreadInfo;
/* If pipe-workers will use some tcl subsystem, we can use Tcl_Alloc without
* more overhead for finalize thread (should be executed anyway)
*
* #define _PTI_USE_CKALLOC 1
*/
/*
* State of the pipe-worker.
*
* State PTI_STATE_STOP possible from idle state only, worker owns TI structure.
* Otherwise PTI_STATE_END used (main thread hold ownership of the TI).
*/
enum PipeWorkerStates {
PTI_STATE_IDLE = 0, /* idle or not yet initialzed */
PTI_STATE_WORK = 1, /* in work */
PTI_STATE_STOP = 2, /* thread should stop work (owns TI structure) */
PTI_STATE_END = 4, /* thread should stop work (worker is busy) */
PTI_STATE_DOWN = 8 /* worker is down */
};
MODULE_SCOPE
TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr,
void *clientData, HANDLE wakeEvent);
MODULE_SCOPE int TclPipeThreadWaitForSignal(
TclPipeThreadInfo **pipeTIPtr);
static inline void
TclPipeThreadSignal(
TclPipeThreadInfo **pipeTIPtr)
{
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
if (pipeTI) {
SetEvent(pipeTI->evControl);
}
};
static inline int
TclPipeThreadIsAlive(
TclPipeThreadInfo **pipeTIPtr)
{
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
return (pipeTI && pipeTI->state != PTI_STATE_DOWN);
};
MODULE_SCOPE int TclPipeThreadStopSignal(TclPipeThreadInfo **pipeTIPtr,
HANDLE wakeEvent);
MODULE_SCOPE void TclPipeThreadStop(TclPipeThreadInfo **pipeTIPtr,
HANDLE hThread);
MODULE_SCOPE void TclPipeThreadExit(TclPipeThreadInfo **pipeTIPtr);
#endif /* _TCLWININT */
|
Changes to win/tclWinLoad.c.
| ︙ | ︙ | |||
86 87 88 89 90 91 92 | * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; | | | | | | | | | | | | | | | | | | | | | | | | | | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 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 |
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
/*
* Remember the first error on load attempt to be used if the
* second load attempt below also fails.
*/
firstError = (nativeName == NULL) ?
ERROR_MOD_NOT_FOUND : GetLastError();
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds);
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
if (hInstance == NULL) {
DWORD lastError;
Tcl_Obj *errMsg;
/*
* We choose to only use the error from the second call if the first
* call failed due to the file not being found. Else stick to the
* first error for reporting purposes.
*/
if (firstError == ERROR_MOD_NOT_FOUND ||
firstError == ERROR_DLL_NOT_FOUND) {
lastError = GetLastError();
} else {
lastError = firstError;
}
errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
TclGetString(pathPtr));
/*
* Check for possible DLL errors. This doesn't work quite right,
* because Windows seems to only return ERROR_MOD_NOT_FOUND for just
* about any problem, but it's better than nothing. It'd be even
* better if there was a way to get what DLLs
*/
if (interp) {
switch (lastError) {
case ERROR_MOD_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", (char *)NULL);
goto notFoundMsg;
case ERROR_DLL_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", (char *)NULL);
notFoundMsg:
Tcl_AppendToObj(errMsg, "this library or a dependent library"
" could not be found in library path", TCL_INDEX_NONE);
break;
case ERROR_PROC_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", (char *)NULL);
Tcl_AppendToObj(errMsg, "A function specified in the import"
" table could not be resolved by the system. Windows"
" is not telling which one, I'm sorry.", TCL_INDEX_NONE);
break;
case ERROR_INVALID_DLL:
Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", (char *)NULL);
Tcl_AppendToObj(errMsg, "this library or a dependent library"
" is damaged", TCL_INDEX_NONE);
break;
case ERROR_DLL_INIT_FAILED:
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (char *)NULL);
Tcl_AppendToObj(errMsg, "the library initialization"
" routine failed", TCL_INDEX_NONE);
break;
case ERROR_BAD_EXE_FORMAT:
Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", (char *)NULL);
Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE);
break;
default:
Tcl_WinConvertError(lastError);
Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), TCL_INDEX_NONE);
}
Tcl_SetObjResult(interp, errMsg);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
sym2 = Tcl_DStringAppend(&ds, symbol, TCL_INDEX_NONE);
proc = (void *)GetProcAddress(hInstance, sym2);
Tcl_DStringFree(&ds);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
| | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
sym2 = Tcl_DStringAppend(&ds, symbol, TCL_INDEX_NONE);
proc = (void *)GetProcAddress(hInstance, sym2);
Tcl_DStringFree(&ds);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, (char *)NULL);
}
return proc;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to win/tclWinNotify.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | static int initialized = 0; static CRITICAL_SECTION notifierMutex; /* * Static routines defined in this file. */ | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | static int initialized = 0; static CRITICAL_SECTION notifierMutex; /* * Static routines defined in this file. */ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); /* *---------------------------------------------------------------------- * * Tcl_InitNotifier -- * * Initializes the platform specific notifier state. |
| ︙ | ︙ | |||
421 422 423 424 425 426 427 | } /* *---------------------------------------------------------------------- * * TclpNotifierData -- * | | | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | } /* *---------------------------------------------------------------------- * * TclpNotifierData -- * * This function returns a void pointer to be associated * with a Tcl_AsyncHandler. * * Results: * On Windows, returns always NULL. * * Side effects: * None. |
| ︙ | ︙ |
Changes to win/tclWinPanic.c.
|
| | | 1 2 3 4 5 6 7 8 | /* * tclWinPanic.c -- * * Contains the Windows-specific command-line panic proc. * * Copyright © 2013 Jan Nijtmans. * All rights reserved. * |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
Tcl_ConsolePanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 26000
va_list argList;
WCHAR msgString[TCL_MAX_WARN_LEN];
char buf[TCL_MAX_WARN_LEN * 3];
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
/*
* This structure describes the channel type structure for command pipe based
* I/O.
*/
static const Tcl_ChannelType pipeChannelType = {
| | | | | | | | | | | | | | | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
/*
* This structure describes the channel type structure for command pipe based
* I/O.
*/
static const Tcl_ChannelType pipeChannelType = {
"pipe",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
PipeInputProc,
PipeOutputProc,
NULL, /* Deprecated. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
PipeWatchProc,
PipeGetHandleProc,
PipeClose2Proc,
PipeBlockModeProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
NULL, /* Seek proc. */
PipeThreadActionProc,
NULL /* Truncate proc. */
};
/*
*----------------------------------------------------------------------
*
* PipeInit --
*
|
| ︙ | ︙ | |||
534 535 536 537 538 539 540 |
Tcl_DString ds;
const WCHAR *nativePath;
/*
* Map the access bits to the NT access mode.
*/
| | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 |
Tcl_DString ds;
const WCHAR *nativePath;
/*
* Map the access bits to the NT access mode.
*/
switch (mode & O_ACCMODE) {
case O_RDONLY:
accessMode = GENERIC_READ;
break;
case O_WRONLY:
accessMode = GENERIC_WRITE;
break;
case O_RDWR:
|
| ︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 |
*
* If we are starting a GUI process, they don't automatically get a
* console, so it doesn't matter if they are started as foreground or
* detached processes. The GUI window will still pop up to the foreground.
*/
if (HasConsole()) {
| | | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
*
* If we are starting a GUI process, they don't automatically get a
* console, so it doesn't matter if they are started as foreground or
* detached processes. The GUI window will still pop up to the foreground.
*/
if (HasConsole()) {
createFlags = 0;
} else if (applType == APPL_DOS) {
/*
* Under NT, 16-bit DOS applications will not run unless they can
* be attached to a console. If we are running without a console,
* run the 16-bit program as an normal process inside of a hidden
* console application, and then run that hidden console as a
* detached process.
|
| ︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 |
CloseHandle(startInfo.hStdOutput);
}
if (startInfo.hStdError != INVALID_HANDLE_VALUE) {
CloseHandle(startInfo.hStdError);
}
return result;
}
| < | 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 |
CloseHandle(startInfo.hStdOutput);
}
if (startInfo.hStdError != INVALID_HANDLE_VALUE) {
CloseHandle(startInfo.hStdError);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* HasConsole --
*
* Determines whether the current application is attached to a console.
|
| ︙ | ︙ | |||
1317 1318 1319 1320 1321 1322 1323 | } Tcl_DStringInit(&ds); strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); if ((ext != NULL) && | | | | 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 |
}
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
if ((ext != NULL) &&
(strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) {
applType = APPL_DOS;
break;
}
hFile = CreateFileW(nativeFullPath,
GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
continue;
}
header.e_magic = 0;
ReadFile(hFile, (void *)&header, sizeof(header), &read, NULL);
if (header.e_magic != IMAGE_DOS_SIGNATURE) {
/*
* Doesn't have the magic number for relocatable executables. If
* filename ends with .com, assume it's a DOS application anyhow.
* Note that we didn't make this assumption at first, because some
* supposed .com files are really 32-bit executables with all the
* magic numbers and everything.
|
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 | /* * The DWORD at header.e_lfanew points to yet another magic number. */ buf[0] = '\0'; SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN); | | | 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 |
/*
* The DWORD at header.e_lfanew points to yet another magic number.
*/
buf[0] = '\0';
SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN);
ReadFile(hFile, (void *)buf, 2, &read, NULL);
CloseHandle(hFile);
if ((buf[0] == 'N') && (buf[1] == 'E')) {
applType = APPL_WIN3X;
} else if ((buf[0] == 'P') && (buf[1] == 'E')) {
applType = APPL_WIN32;
} else {
|
| ︙ | ︙ | |||
1459 1460 1461 1462 1463 1464 1465 |
const char *bspos)
{
if (!bspos) {
if (current > start) { /* part before current (special) */
Tcl_DStringAppend(dsPtr, start, (int) (current - start));
}
} else {
| | | 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 |
const char *bspos)
{
if (!bspos) {
if (current > start) { /* part before current (special) */
Tcl_DStringAppend(dsPtr, start, (int) (current - start));
}
} else {
if (bspos > start) { /* part before first backslash */
Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
}
while (bspos++ < current) { /* each backslash twice */
TclDStringAppendLiteral(dsPtr, "\\\\");
}
}
}
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 |
* main quotes, so `\` remains `\`, but important - not at end of part,
* because results as before the quote, so `%\%\` should be escaped as
* `"%\%"\\`).
*/
TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
do {
| | | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
* main quotes, so `\` remains `\`, but important - not at end of part,
* because results as before the quote, so `%\%\` should be escaped as
* `"%\%"\\`).
*/
TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
do {
*bspos = NULL;
special++;
if (*special == '\\') {
/*
* Bypass backslashes (and mark first backslash position).
*/
special = BuildCmdLineBypassBS(special, bspos);
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable),
0, NULL);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_READABLE;
} else {
| | | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 |
infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable),
0, NULL);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_READABLE;
} else {
infoPtr->readTI = NULL;
infoPtr->readThread = 0;
}
if (writeFile != NULL) {
/*
* Start the background writer thread.
*/
infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable),
0, NULL);
SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_WRITABLE;
} else {
infoPtr->writeTI = NULL;
infoPtr->writeThread = 0;
}
/*
* For backward compatibility with previous versions of Tcl, we use
* "file%d" as the base name for pipes even though it would be more
* natural to use "pipe%d". Use the pointer to keep the channel names
* unique, in case channels share handles (stdin/stdout).
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 |
if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) {
Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"pipe creation failed: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
| | | | 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 |
if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) {
Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"pipe creation failed: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
*rchan = Tcl_MakeFileChannel((void *)readHandle, TCL_READABLE);
Tcl_RegisterChannel(interp, *rchan);
*wchan = Tcl_MakeFileChannel((void *)writeHandle, TCL_WRITABLE);
Tcl_RegisterChannel(interp, *wchan);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2116 2117 2118 2119 2120 2121 2122 |
* Wrap the error file into a channel and give it to the cleanup
* routine.
*/
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
| | < | | 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 |
* Wrap the error file into a channel and give it to the cleanup
* routine.
*/
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);
}
|
| ︙ | ︙ | |||
2512 2513 2514 2515 2516 2517 2518 |
void **handlePtr) /* Where to store the handle. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr;
if (direction == TCL_READABLE && infoPtr->readFile) {
filePtr = (WinFile*) infoPtr->readFile;
| | | | 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 |
void **handlePtr) /* Where to store the handle. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr;
if (direction == TCL_READABLE && infoPtr->readFile) {
filePtr = (WinFile*) infoPtr->readFile;
*handlePtr = (void *)filePtr->handle;
return TCL_OK;
}
if (direction == TCL_WRITABLE && infoPtr->writeFile) {
filePtr = (WinFile*) infoPtr->writeFile;
*handlePtr = (void *)filePtr->handle;
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2760 2761 2762 2763 2764 2765 2766 |
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
size_t i;
Tcl_Obj *resultPtr;
if (objc > 2) {
| | | 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 |
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
size_t i;
Tcl_Obj *resultPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channel?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
} else {
chan = Tcl_GetChannel(interp, TclGetString(objv[1]),
NULL);
|
| ︙ | ︙ | |||
3218 3219 3220 3221 3222 3223 3224 |
namePtr = (char *) name;
length = GetTempPathW(MAX_PATH, name);
if (length == 0) {
goto gotError;
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
| | | 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 |
namePtr = (char *) name;
length = GetTempPathW(MAX_PATH, name);
if (length == 0) {
goto gotError;
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
const char *string = TclGetStringFromObj(basenameObj, &length);
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(string, length, &buf);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf));
namePtr += Tcl_DStringLength(&buf);
Tcl_DStringFree(&buf);
} else {
|
| ︙ | ︙ | |||
3263 3264 3265 3266 3267 3268 3269 |
if (resultingNameObj) {
Tcl_Obj *tmpObj = TclpNativeToNormalized(name);
Tcl_AppendObjToObj(resultingNameObj, tmpObj);
TclDecrRefCount(tmpObj);
}
| | | 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 |
if (resultingNameObj) {
Tcl_Obj *tmpObj = TclpNativeToNormalized(name);
Tcl_AppendObjToObj(resultingNameObj, tmpObj);
TclDecrRefCount(tmpObj);
}
return Tcl_MakeFileChannel((void *)handle,
TCL_READABLE|TCL_WRITABLE);
gotError:
Tcl_WinConvertError(GetLastError());
return NULL;
}
|
| ︙ | ︙ | |||
3395 3396 3397 3398 3399 3400 3401 |
/*
* End of work, check the owner of the TI structure.
*/
if (state != PTI_STATE_STOP) {
*pipeTIPtr = NULL;
} else {
| | | | 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 |
/*
* End of work, check the owner of the TI structure.
*/
if (state != PTI_STATE_STOP) {
*pipeTIPtr = NULL;
} else {
pipeTI->evWakeUp = NULL;
}
if (wakeEvent) {
SetEvent(wakeEvent);
}
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 | /* * The following defines redefine the Windows Socket errors as * BSD errors so Tcl_PosixError can do the right thing. */ #ifndef ENOTEMPTY | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | /* * The following defines redefine the Windows Socket errors as * BSD errors so Tcl_PosixError can do the right thing. */ #ifndef ENOTEMPTY # define ENOTEMPTY 41 /* Directory not empty */ #endif #ifndef EREMOTE # define EREMOTE 66 /* The object is remote */ #endif #ifndef EPFNOSUPPORT # define EPFNOSUPPORT 96 /* Protocol family not supported */ #endif |
| ︙ | ︙ | |||
242 243 244 245 246 247 248 | #ifndef ETXTBSY # define ETXTBSY 139 /* Text file or pseudo-device busy */ #endif #ifndef EWOULDBLOCK # define EWOULDBLOCK 140 /* Operation would block */ #endif | < | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | #ifndef ETXTBSY # define ETXTBSY 139 /* Text file or pseudo-device busy */ #endif #ifndef EWOULDBLOCK # define EWOULDBLOCK 140 /* Operation would block */ #endif /* Visual Studio doesn't have these, so just choose some high numbers */ #ifndef ESOCKTNOSUPPORT # define ESOCKTNOSUPPORT 240 /* Socket type not supported */ #endif #ifndef ESHUTDOWN # define ESHUTDOWN 241 /* Can't send after socket shutdown */ #endif |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 348 349 350 351 352 353 354 | #endif #ifndef W_OK # define W_OK 02 #endif #ifndef R_OK # define R_OK 04 #endif /* * Define macros to query file type bits, if they're not already * defined. */ #ifndef S_IFLNK | > > > | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 | #endif #ifndef W_OK # define W_OK 02 #endif #ifndef R_OK # define R_OK 04 #endif #ifndef O_ACCMODE # define O_ACCMODE (O_RDONLY | O_WRONLY | O_RDWR) #endif /* * Define macros to query file type bits, if they're not already * defined. */ #ifndef S_IFLNK |
| ︙ | ︙ | |||
407 408 409 410 411 412 413 | #ifndef S_ISLNK # ifdef S_IFLNK # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) # else # define S_ISLNK(m) 0 # endif #endif /* !S_ISLNK */ | < | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 | #ifndef S_ISLNK # ifdef S_IFLNK # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) # else # define S_ISLNK(m) 0 # endif #endif /* !S_ISLNK */ /* * Define MAXPATHLEN in terms of MAXPATH if available */ #ifndef MAXPATH # define MAXPATH MAX_PATH |
| ︙ | ︙ | |||
517 518 519 520 521 522 523 | 0, (HGLOBAL)ptr)) #define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ 0, (LPVOID)ptr, size)) /* This type is not defined in the Windows headers */ #define socklen_t int | < < < | 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 | 0, (HGLOBAL)ptr)) #define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ 0, (LPVOID)ptr, size)) /* This type is not defined in the Windows headers */ #define socklen_t int /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. */ #define TclpReleaseFile(file) Tcl_Free(file) /* * The following macros and declarations wrap the C runtime library * functions. */ #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER 0xFFFFFFFF #endif /* INVALID_SET_FILE_POINTER */ #ifndef LABEL_SECURITY_INFORMATION # define LABEL_SECURITY_INFORMATION (0x00000010L) #endif #endif /* _TCLWINPORT */ |
Changes to win/tclWinReg.c.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) /* * The following flag is used in OpenKeys to indicate that the specified key * should be created if it doesn't currently exist. */ | | | > | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
/*
* The following flag is used in OpenKeys to indicate that the specified key
* should be created if it doesn't currently exist.
*/
enum OpenKeysFlags {
REG_CREATE = 1
};
/*
* The following tables contain the mapping from registry root names to the
* system predefined keys.
*/
static const char *const rootKeyNames[] = {
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 | HKEY key; /* * Create the key and then close it immediately. */ mode |= KEY_ALL_ACCESS; | | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
HKEY key;
/*
* Create the key and then close it immediately.
*/
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, objv[n], mode, REG_CREATE, &key) != TCL_OK) {
return TCL_ERROR;
}
RegCloseKey(key);
return TCL_OK;
} else if (argc == 3) {
return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL,
mode);
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
Tcl_Free(buffer);
return TCL_ERROR;
}
if (*keyName == '\0') {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("bad key: cannot delete root keys", -1));
| | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
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", (char *)NULL);
Tcl_Free(buffer);
return TCL_ERROR;
}
tail = strrchr(keyName, '\\');
if (tail) {
*tail++ = '\0';
|
| ︙ | ︙ | |||
849 850 851 852 853 854 855 | Tcl_DStringInit(&buf); Tcl_WCharToUtfDString(wp, wcslen(wp), &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); | | | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 |
Tcl_DStringInit(&buf);
Tcl_WCharToUtfDString(wp, wcslen(wp), &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
while (*wp++ != 0); /* empty loop body */
p = (char *) wp;
Tcl_DStringFree(&buf);
}
Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
WCHAR *wp = (WCHAR *) Tcl_DStringValue(&data);
Tcl_DStringInit(&buf);
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
* indicating the end of the list. Note that we need to reset size after
* each iteration because RegEnumValue smashes the old value.
*/
size = MAX_KEY_LENGTH;
while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer),
&size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {
| < | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
* indicating the end of the list. Note that we need to reset size after
* each iteration because RegEnumValue smashes the old value.
*/
size = MAX_KEY_LENGTH;
while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer),
&size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 |
}
} else {
rootName = name;
}
if (!rootName) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad key \"%s\": must start with a valid root", name));
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
}
} else {
rootName = name;
}
if (!rootName) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad key \"%s\": must start with a valid root", name));
Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", (char *)NULL);
return TCL_ERROR;
}
/*
* Split the root into root and subkey portions.
*/
|
| ︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 |
REGSAM mode) /* Mode flags to pass. */
{
DWORD result, size;
Tcl_DString subkey;
HKEY hKey;
REGSAM saveMode = mode;
static int checkExProc = 0;
| | > > > > | 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 |
REGSAM mode) /* Mode flags to pass. */
{
DWORD result, size;
Tcl_DString subkey;
HKEY hKey;
REGSAM saveMode = mode;
static int checkExProc = 0;
typedef LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD);
static regDeleteKeyExProc regDeleteKeyEx = (regDeleteKeyExProc) NULL;
/* Really RegDeleteKeyExW() but that's not
* available on all versions of Windows
* supported by Tcl. */
/*
* Do not allow NULL or empty key name.
*/
if (!keyName || *keyName == '\0') {
return ERROR_BADKEY;
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 |
*/
if (mode && !checkExProc) {
HMODULE handle;
checkExProc = 1;
handle = GetModuleHandleW(L"ADVAPI32");
| | | | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 |
*/
if (mode && !checkExProc) {
HMODULE handle;
checkExProc = 1;
handle = GetModuleHandleW(L"ADVAPI32");
regDeleteKeyEx = (regDeleteKeyExProc) (void *)
GetProcAddress(handle, "RegDeleteKeyExW");
}
if (mode && regDeleteKeyEx) {
result = regDeleteKeyEx(startKey, keyName, mode, 0);
} else {
result = RegDeleteKeyW(startKey, keyName);
}
break;
} else if (result == ERROR_SUCCESS) {
result = RecursiveDeleteKey(hKey,
(const WCHAR *) Tcl_DStringValue(&subkey), mode);
|
| ︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 |
0, (int *) &type) != TCL_OK) {
if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
mode |= KEY_ALL_ACCESS;
| | | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 |
0, (int *) &type) != TCL_OK) {
if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, keyNameObj, mode, REG_CREATE, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetStringFromObj(valueNameObj, &len);
Tcl_DStringInit(&nameBuf);
valueName = (char *) Tcl_UtfToWCharDString(valueName, len, &nameBuf);
|
| ︙ | ︙ | |||
1535 1536 1537 1538 1539 1540 1541 |
--length;
}
msgPtr[length] = 0;
msg = msgPtr;
}
snprintf(id, sizeof(id), "%ld", error);
| | | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 |
--length;
}
msgPtr[length] = 0;
msg = msgPtr;
}
snprintf(id, sizeof(id), "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *)NULL);
Tcl_AppendToObj(resultPtr, msg, length);
Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);
}
}
|
| ︙ | ︙ |
Changes to win/tclWinSerial.c.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | */ TCL_DECLARE_MUTEX(serialMutex) /* * Bit masks used in the flags field of the SerialInfo structure below. */ | | | | | | > | | | | | | | | | | > | | | | | > | > | 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 |
*/
TCL_DECLARE_MUTEX(serialMutex)
/*
* Bit masks used in the flags field of the SerialInfo structure below.
*/
enum SerialFlags {
SERIAL_PENDING = 1 << 0, /* Message is pending in the queue. */
SERIAL_ASYNC = 1 << 1, /* Channel is non-blocking. */
/*
* Bit masks used in the sharedFlags field of the SerialInfo structure
* below.
*/
SERIAL_EOF = 1 << 2, /* Serial has reached EOF. */
SERIAL_ERROR = 1 << 4,
/*
* Bit masks used for noting whether to drain or discard output on close.
* They are disjoint from each other; at most one may be set at a time.
*/
SERIAL_CLOSE_DRAIN = 1<<6, /* Drain all output on close. */
SERIAL_CLOSE_DISCARD = 1<<7,/* Discard all output on close. */
SERIAL_CLOSE_MASK = 3<<6 /* Both two bits above. */
};
/*
* Default time to block between checking status on the serial port.
*/
#define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */
/*
* Win32 read/write error masks for values returned by ClearCommError()
*/
enum TclWinCommErrorMasks {
SERIAL_READ_ERRORS = /* Errors in the reader side. */
(CE_RXOVER | CE_OVERRUN | CE_RXPARITY | CE_FRAME | CE_BREAK),
SERIAL_WRITE_ERRORS = /* Errors in the writer side. */
(CE_TXFULL | CE_PTO)
};
/*
* This structure describes per-instance data for a serial based channel.
*/
typedef struct SerialInfo {
HANDLE handle;
struct SerialInfo *nextPtr; /* Pointer to next registered serial. */
Tcl_Channel channel; /* Pointer to channel structure. */
int validMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
int watchMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events should be reported. */
int flags; /* State flags, see above for a list. */
int readable; /* Flag that the channel is readable. */
int writable; /* Flag that the channel is writable. */
int blockTime; /* Maximum blocktime in msec. */
unsigned long long lastEventTime;
/* Time in milliseconds since last readable
* event. */
/* Next readable event only after blockTime */
DWORD error; /* pending error code returned by
* ClearCommError() */
DWORD lastError; /* last error code, can be fetched with
* fconfigure chan -lasterror */
DWORD sysBufRead; /* Win32 system buffer size for read ops,
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
/*
* This structure describes the channel type structure for command serial
* based IO.
*/
static const Tcl_ChannelType serialChannelType = {
| | | | | | | | | | | | | | | | | | | 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 |
/*
* This structure describes the channel type structure for command serial
* based IO.
*/
static const Tcl_ChannelType serialChannelType = {
"serial",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
SerialInputProc,
SerialOutputProc,
NULL, /* Deprecated. */
SerialSetOptionProc,
SerialGetOptionProc,
SerialWatchProc,
SerialGetHandleProc,
SerialCloseProc,
SerialBlockProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
NULL, /* Seek proc. */
SerialThreadActionProc,
NULL /* Truncate proc. */
};
/*
*----------------------------------------------------------------------
*
* SerialInit --
*
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
static unsigned long long
SerialGetMilliseconds(void)
{
Tcl_Time time;
Tcl_GetTime(&time);
| | > | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
static unsigned long long
SerialGetMilliseconds(void)
{
Tcl_Time time;
Tcl_GetTime(&time);
return (unsigned long long)time.sec * 1000
+ (unsigned long)time.usec / 1000;
}
/*
*----------------------------------------------------------------------
*
* SerialSetupProc --
*
|
| ︙ | ︙ | |||
557 558 559 560 561 562 563 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int SerialBlockProc( | | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
SerialBlockProc(
void *instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
int errorCode = 0;
SerialInfo *infoPtr = (SerialInfo *) instanceData;
/*
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 | * Closes the physical channel. * *---------------------------------------------------------------------- */ static int SerialCloseProc( | | < | | 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 |
* Closes the physical channel.
*
*----------------------------------------------------------------------
*/
static int
SerialCloseProc(
void *instanceData, /* Pointer to SerialInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
SerialInfo *serialPtr = (SerialInfo *) instanceData;
int errorCode = 0, result = 0;
SerialInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (serialPtr->validMask & TCL_READABLE) {
PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
CloseHandle(serialPtr->osRead.hEvent);
}
serialPtr->validMask &= ~TCL_READABLE;
if (serialPtr->writeThread) {
TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread);
CloseHandle(serialPtr->osWrite.hEvent);
CloseHandle(serialPtr->evWritable);
CloseHandle(serialPtr->writeThread);
serialPtr->writeThread = NULL;
PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
|
| ︙ | ︙ | |||
851 852 853 854 855 856 857 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int SerialInputProc( | | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
* Reads input from the actual channel.
*
*----------------------------------------------------------------------
*/
static int
SerialInputProc(
void *instanceData, /* Serial state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DWORD bytesRead = 0;
|
| ︙ | ︙ | |||
958 959 960 961 962 963 964 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int SerialOutputProc( | | | 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
* Writes output on the actual channel.
*
*----------------------------------------------------------------------
*/
static int
SerialOutputProc(
void *instanceData, /* Serial state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DWORD bytesWritten, timeout;
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 | * None. * *---------------------------------------------------------------------- */ static void SerialWatchProc( | | | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 |
* None.
*
*----------------------------------------------------------------------
*/
static void
SerialWatchProc(
void *instanceData, /* Serial state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
SerialInfo **nextPtrPtr, *ptr;
SerialInfo *infoPtr = (SerialInfo *) instanceData;
int oldMask = infoPtr->watchMask;
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 | * None. * *---------------------------------------------------------------------- */ static int SerialGetHandleProc( | | | | | 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 |
* None.
*
*----------------------------------------------------------------------
*/
static int
SerialGetHandleProc(
void *instanceData, /* The serial state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
*handlePtr = (void *)infoPtr->handle;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SerialWriterThread --
|
| ︙ | ︙ | |||
1277 1278 1279 1280 1281 1282 1283 |
*/
static DWORD WINAPI
SerialWriterThread(
LPVOID arg)
{
TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
| | | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 |
*/
static DWORD WINAPI
SerialWriterThread(
LPVOID arg)
{
TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
SerialInfo *infoPtr = NULL; /* access info only after success init/wait */
DWORD bytesWritten, toWrite;
char *buf;
OVERLAPPED myWrite; /* Have an own OVERLAPPED in this thread. */
for (;;) {
/*
* Wait for the main thread to signal before attempting to write.
|
| ︙ | ︙ | |||
1476 1477 1478 1479 1480 1481 1482 |
* are shared between multiple channels (stdin/stdout).
*/
TclWinGenerateChannelName(channelName, "file", infoPtr);
infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
infoPtr, permissions);
| < | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 |
* are shared between multiple channels (stdin/stdout).
*/
TclWinGenerateChannelName(channelName, "file", infoPtr);
infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
infoPtr, permissions);
SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite);
PurgeComm(handle,
PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR);
/*
* Default is blocking.
*/
|
| ︙ | ︙ | |||
1608 1609 1610 1611 1612 1613 1614 | * May modify an option on a device. * *---------------------------------------------------------------------- */ static int SerialSetOptionProc( | | | < < | 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 |
* May modify an option on a device.
*
*----------------------------------------------------------------------
*/
static int
SerialSetOptionProc(
void *instanceData, /* Serial state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DCB dcb;
BOOL result, flag;
size_t len, vlen;
Tcl_DString ds;
const WCHAR *native;
Tcl_Size argc;
const char **argv;
/*
* Parse options. This would be far easier if we had Tcl_Objs to work with
* as that would let us use Tcl_GetIndexFromObj()...
*/
len = strlen(optionName);
vlen = strlen(value);
|
| ︙ | ︙ | |||
1651 1652 1653 1654 1655 1656 1657 |
infoPtr->flags |= SERIAL_CLOSE_DISCARD;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -closemode: must be"
" default, discard, or drain", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
| | | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 |
infoPtr->flags |= SERIAL_CLOSE_DISCARD;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -closemode: must be"
" default, discard, or drain", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", (char *)NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1676 1677 1678 1679 1680 1681 1682 |
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -mode: should be baud,parity,data,stop",
value));
| | | 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 |
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -mode: should be baud,parity,data,stop",
value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL);
}
return TCL_ERROR;
}
/*
* Default settings for serial communications.
*/
|
| ︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 |
dcb.fOutxDsrFlow = TRUE;
dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -handshake: must be one of"
" xonxoff, rtscts, dtrdsr or none", value));
| | | 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 |
dcb.fOutxDsrFlow = TRUE;
dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -handshake: must be one of"
" xonxoff, rtscts, dtrdsr or none", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", (char *)NULL);
}
return TCL_ERROR;
}
if (!SetCommState(infoPtr->handle, &dcb)) {
goto setStateFailed;
}
|
| ︙ | ︙ | |||
1768 1769 1770 1771 1772 1773 1774 |
return TCL_ERROR;
}
if (argc != 2) {
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
| | > | | 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 |
return TCL_ERROR;
}
if (argc != 2) {
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character",
TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", (char *)NULL);
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
/*
* These dereferences are safe, even in the zero-length string cases,
|
| ︙ | ︙ | |||
1791 1792 1793 1794 1795 1796 1797 |
dcb.XonChar = argv[0][0];
dcb.XoffChar = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
Tcl_UniChar character = 0;
int charLen;
| | | | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 |
dcb.XonChar = argv[0][0];
dcb.XoffChar = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
Tcl_UniChar character = 0;
int charLen;
charLen = TclUtfToUniChar(argv[0], &character);
if ((character > 0xFF) || argv[0][charLen]) {
goto badXchar;
}
dcb.XonChar = (char) character;
charLen = TclUtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
dcb.XoffChar = (char) character;
}
Tcl_Free((void *)argv);
|
| ︙ | ︙ | |||
1826 1827 1828 1829 1830 1831 1832 |
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -ttycontrol: should be "
"a list of signal,value pairs", value));
| | | | | | | 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 |
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -ttycontrol: should be "
"a list of signal,value pairs", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", (char *)NULL);
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
for (i = 0; i < argc - 1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
res = TCL_ERROR;
break;
}
if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETDTR : CLRDTR))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set DTR signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", (char *)NULL);
}
res = TCL_ERROR;
break;
}
} else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETRTS : CLRRTS))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set RTS signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", (char *)NULL);
}
res = TCL_ERROR;
break;
}
} else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETBREAK : CLRBREAK))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set BREAK signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", (char *)NULL);
}
res = TCL_ERROR;
break;
}
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal name \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL",
(char *)NULL);
}
res = TCL_ERROR;
break;
}
}
Tcl_Free((void *)argv);
|
| ︙ | ︙ | |||
1919 1920 1921 1922 1923 1924 1925 |
Tcl_Free((void *)argv);
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -sysbuffer: should be "
"a list of one or two integers > 0", value));
| | | 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 |
Tcl_Free((void *)argv);
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -sysbuffer: should be "
"a list of one or two integers > 0", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", (char *)NULL);
}
return TCL_ERROR;
}
if (!SetupComm(infoPtr->handle, inSize, outSize)) {
if (interp != NULL) {
Tcl_WinConvertError(GetLastError());
|
| ︙ | ︙ | |||
2032 2033 2034 2035 2036 2037 2038 | * reused at any time subsequent to the call. * *---------------------------------------------------------------------- */ static int SerialGetOptionProc( | | | < < | 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 |
* reused at any time subsequent to the call.
*
*----------------------------------------------------------------------
*/
static int
SerialGetOptionProc(
void *instanceData, /* Serial state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DCB dcb;
size_t len;
int valid = 0; /* Flag if valid option parsed. */
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
|
| ︙ | ︙ |
Changes to win/tclWinSock.c.
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) | | | | | | | > | > > > > > | > | 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 |
* Helper macros to make parts of this file clearer. The macros do exactly
* what they say on the tin. :-) They also only ever refer to their arguments
* once, and so can be used without regard to side effects.
*/
#define SET_BITS(var, bits) ((var) |= (bits))
#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
#define GOT_BITS(var, bits) (((var) & (bits)) != 0)
/* "sock" + a pointer in hex + \0 */
#define SOCK_CHAN_LENGTH (16 + TCL_INTEGER_SPACE)
/*
* The following variable is used to tell whether this module has been
* initialized. If 1, initialization of sockets was successful, if -1 then
* socket initialization failed (WSAStartup failed).
*/
static int initialized = 0;
static const WCHAR className[] = L"TclSocket";
TCL_DECLARE_MUTEX(socketMutex)
/*
* The following defines declare the messages used on socket windows.
*/
enum TclSocketMessages {
SOCKET_MESSAGE = WM_USER+1, /* Sent by OS: something happened. */
SOCKET_SELECT = WM_USER+2, /* Adjust select mask. */
SOCKET_TERMINATE = WM_USER+3/* Stop worker thread. */
};
/*
* Operations used with a SOCKET_SELECT message.
*/
enum SocketSelectOperations {
SELECT = TRUE, /* Add socket to select. */
UNSELECT = FALSE /* Remove socket from select. */
};
/*
* This is needed to comply with the strict aliasing rules of GCC, but it also
* simplifies casting between the different sockaddr types.
*/
typedef union {
|
| ︙ | ︙ | |||
146 147 148 149 150 151 152 |
*/
struct addrinfo *addrlist; /* Addresses to connect to. */
struct addrinfo *addr; /* Iterator over addrlist. */
struct addrinfo *myaddrlist;/* Local address. */
struct addrinfo *myaddr; /* Iterator over myaddrlist. */
int connectError; /* Cache status of async socket. */
| | > | | | < | < | < | | | | | | > | 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 |
*/
struct addrinfo *addrlist; /* Addresses to connect to. */
struct addrinfo *addr; /* Iterator over addrlist. */
struct addrinfo *myaddrlist;/* Local address. */
struct addrinfo *myaddr; /* Iterator over myaddrlist. */
int connectError; /* Cache status of async socket. */
int cachedBlocking; /* Cache blocking mode of async socket. */
volatile int notifierConnectError;
/* Async connect error set by notifier thread.
* This error is still a windows error code.
* Access must be protected by semaphore */
struct TcpState *nextPtr; /* The next socket on the per-thread socket
* list. */
};
/*
* These bits may be OR'ed together into the "flags" field of a TcpState
* structure.
*/
enum TcpStateFlags {
TCP_NONBLOCKING = 1<<0, /* Socket with non-blocking I/O. */
TCP_ASYNC_CONNECT = 1<<1, /* Async connect in progress. */
SOCKET_EOF = 1<<2, /* A zero read happened on the socket. */
SOCKET_PENDING = 1<<3, /* A message has been sent for this socket */
TCP_ASYNC_PENDING = 1<<4, /* TcpConnect was called to process an async
* connect. This flag indicates that reentry is
* still pending. */
TCP_ASYNC_FAILED = 1<<5, /* An async connect finally failed. */
TCP_ASYNC_TEST_MODE = 1<<8 /* Async testing activated. Do not
* automatically continue connection
* process */
};
/*
* The following structure is what is added to the Tcl event queue when a
* socket event occurs.
*/
typedef struct {
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | /* * This defines the minimum buffersize maintained by the kernel. */ #define TCP_BUFFER_SIZE 4096 | | > > > | < | 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 |
/*
* This defines the minimum buffersize maintained by the kernel.
*/
#define TCP_BUFFER_SIZE 4096
/*
* Per (main) thread data, holding list of things being waited upon and the
* various handles to things doing the waiting/notification.
*/
typedef struct {
HWND hwnd; /* Handle to window for socket messages. */
HANDLE socketThread; /* Thread handling the window */
Tcl_ThreadId threadId; /* Parent thread. */
HANDLE readyEvent; /* Event indicating that a socket event is
* ready. Also used to indicate that the
* socketThread has been initialized and has
* started. */
HANDLE socketListLock; /* Win32 Event to lock the socketList */
TcpState *pendingTcpState; /* This socket is opened but not jet in the
* list. This value is also checked by
* the event structure. */
TcpState *socketList; /* Every open socket in this thread has an
* entry on this list. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 | static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static int WaitForSocketEvent(TcpState *statePtr, int events, int *errorCodePtr); | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static int WaitForSocketEvent(TcpState *statePtr, int events, int *errorCodePtr); static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(void *instanceData, int action); static int TcpCloseProc(void *, Tcl_Interp *); static Tcl_EventCheckProc SocketCheckProc; |
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
/*
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
| | | | | | | | | | | | | | | | | | | > > > > | > > > > > > > > | < | | | | | | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 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 |
/*
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp",
TCL_CHANNEL_VERSION_5,
NULL, /* Deprecated. */
TcpInputProc,
TcpOutputProc,
NULL, /* Deprecated. */
TcpSetOptionProc,
TcpGetOptionProc,
TcpWatchProc,
TcpGetHandleProc,
TcpClose2Proc,
TcpBlockModeProc,
NULL, /* Flush proc. */
NULL, /* Bubbled event handler proc. */
NULL, /* Seek proc. */
TcpThreadActionProc,
NULL /* Truncate proc. */
};
/*
* The following variable holds the network name of this host.
*/
static TclInitProcessGlobalValueProc InitializeHostName;
static ProcessGlobalValue hostName =
{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
/*
*----------------------------------------------------------------------
*
* SendSelectMessage --
*
* Simple wrapper round the SendMessage syscall with a SOCKET_SELECT
* message to add a bit of type safety.
*
*----------------------------------------------------------------------
*/
static inline void
SendSelectMessage(
ThreadSpecificData *tsdPtr, /* Reference to this thread's worker. */
int operation, /* Whether to add or remove from the mask. */
TcpState *payload) /* What socket to add/remove. */
{
SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) operation,
(LPARAM) payload);
}
/*
* Address print debug functions
*/
#if 0
static inline void
printaddrinfo(
struct addrinfo *ai,
char *prefix)
{
char host[NI_MAXHOST], port[NI_MAXSERV];
getnameinfo(ai->ai_addr, ai->ai_addrlen,
host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST | NI_NUMERICSERV);
}
static void
printaddrinfolist(
struct addrinfo *addrlist,
char *prefix)
{
struct addrinfo *ai;
for (ai = addrlist; ai != NULL; ai = ai->ai_next) {
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
void
InitializeHostName(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[256];
| | | > > > | | > > < < | | | < | < | < | < | | 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 |
void
InitializeHostName(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[256];
DWORD length = sizeof(wbuf) / sizeof(WCHAR);
Tcl_DString ds;
Tcl_DStringInit(&ds);
if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) {
/*
* Convert string from WCHAR to utf-8, then change to lowercase,
* then to system encoding.
*/
Tcl_DString inDs;
Tcl_DStringInit(&inDs);
Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &inDs));
Tcl_UtfToExternalDStringEx(NULL, NULL, Tcl_DStringValue(&inDs),
TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &ds, NULL);
Tcl_DStringFree(&inDs);
} else {
TclInitSockets();
/*
* The buffer size of 256 is recommended by the MSDN page that
* documents gethostname() as being always adequate.
*/
Tcl_DStringInit(&ds);
Tcl_DStringSetLength(&ds, 256);
gethostname(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
Tcl_DStringSetLength(&ds, strlen(Tcl_DStringValue(&ds)));
}
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
*lengthPtr = Tcl_DStringLength(&ds);
*valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1);
memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1);
Tcl_DStringFree(&ds);
}
/*
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 | } /* *---------------------------------------------------------------------- * * TclInitSockets -- * | | | | | > | | | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* TclInitSockets --
*
* Initialization of sockets for the thread. Also creates message
* handling window class for the process if needed.
*
* Results:
* Nothing. Panics on failure.
*
* Side effects:
* If not already prepared, initializes the TSD structure and socket
* message handling thread associated to the calling thread for the
* subsystem of the driver.
*
*----------------------------------------------------------------------
*/
void
TclInitSockets(void)
{
/* Then Per thread initialization. */
DWORD id;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
return;
}
InitSocketWindowClass();
/*
* OK, this thread has never done anything with sockets before. Construct
* a worker thread to handle asynchronous events related to sockets
* assigned to _this_ thread.
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->pendingTcpState = NULL;
tsdPtr->socketList = NULL;
tsdPtr->hwnd = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL);
if (tsdPtr->readyEvent == NULL) {
goto initFailure;
}
tsdPtr->socketListLock = CreateEventW(NULL, FALSE, TRUE, NULL);
if (tsdPtr->socketListLock == NULL) {
goto initFailure;
}
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets(void)
{
| | > | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
/*
* Careful! This is a finalizer!
*/
if (tsdPtr == NULL) {
return;
|
| ︙ | ︙ | |||
558 559 560 561 562 563 564 | * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ static int TcpBlockModeProc( | | | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
* Sets the device into blocking or nonblocking mode.
*
*----------------------------------------------------------------------
*/
static int
TcpBlockModeProc(
void *instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 | * * EWOULDBLOCK: if connect is still in progress * * ENOTCONN: if connect failed. This would be the error message * of a recv or sendto syscall so this is emulated here. * * Null: Called by a background operation. Do not block and don't * return any error code. * * Results: | | | < | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
* * EWOULDBLOCK: if connect is still in progress
* * ENOTCONN: if connect failed. This would be the error message
* of a recv or sendto syscall so this is emulated here.
* * Null: Called by a background operation. Do not block and don't
* return any error code.
*
* Results:
* 0 if the connection has completed, -1 if still in progress or there is
* an error.
*
* Side effects:
* Processes socket events off the system queue. May process
* asynchronous connect.
*
*----------------------------------------------------------------------
*/
static int
WaitForConnect(
TcpState *statePtr, /* State of the socket. */
int *errorCodePtr) /* Where to store errors? A passed
* null-pointer activates background mode. */
{
int result;
int oldMode;
/*
* Check if an async connect failed already and error reporting is
* demanded, return the error ENOTCONN.
*/
if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
* - Call by the event queue (errorCodePtr == NULL)
*/
if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
&& errorCodePtr != NULL
| | > | | 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 |
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
* - Call by the event queue (errorCodePtr == NULL)
*/
if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
&& errorCodePtr != NULL
&& GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
*errorCodePtr = EWOULDBLOCK;
return -1;
}
/*
* Be sure to disable event servicing so we are truly modal.
*/
oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
/*
* Loop in the blocking case until the connect signal is present
*/
while (1) {
/*
* Get the statePtr lock.
*/
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Check for connect event.
*/
if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 |
if (errorCodePtr != NULL) {
*errorCodePtr = ENOTCONN;
}
return -1;
}
| | | | | | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
if (errorCodePtr != NULL) {
*errorCodePtr = ENOTCONN;
}
return -1;
}
/*
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
/*
* Background operation returns with no action as there was no connect
* event
*/
if (errorCodePtr == NULL) {
|
| ︙ | ︙ | |||
789 790 791 792 793 794 795 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int TcpInputProc( | | | > | 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 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpInputProc(
void *instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int bytesRead;
DWORD error;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
/*
* First check to see if EOF was already detected, to prevent calling the
* socket stack after the first time EOF is detected.
*/
|
| ︙ | ︙ | |||
880 881 882 883 884 885 886 | } /* * Check for error condition or underflow in non-blocking case. */ if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING) | | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
}
/*
* Check for error condition or underflow in non-blocking case.
*/
if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)
|| (error != WSAEWOULDBLOCK)) {
Tcl_WinConvertError(error);
*errorCodePtr = Tcl_GetErrno();
bytesRead = -1;
break;
}
/*
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 | * Produces output on the socket. * *---------------------------------------------------------------------- */ static int TcpOutputProc( | | | > | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 |
* Produces output on the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpOutputProc(
void *instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int written;
DWORD error;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
/*
* Check if there is an async connect running.
* For blocking sockets terminate connect, otherwise do one step.
* For a non blocking socket return EWOULDBLOCK if connect not terminated
|
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 | * Closes the socket. * *---------------------------------------------------------------------- */ static int TcpCloseProc( | | | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
* Closes the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpCloseProc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
/* TIP #218 */
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
Tcl_WinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
Tcl_Free(thisfd);
}
if (statePtr->addrlist != NULL) {
| | | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 |
Tcl_WinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
Tcl_Free(thisfd);
}
if (statePtr->addrlist != NULL) {
freeaddrinfo(statePtr->addrlist);
}
if (statePtr->myaddrlist != NULL) {
freeaddrinfo(statePtr->myaddrlist);
}
/*
* Clear an eventual tsd info list pointer.
*
* This may be called, if an async socket connect fails or is closed
* between connect and thread action callback.
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 | * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ static int TcpClose2Proc( | | | > | > | | 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 |
* Shuts down one side of the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpClose2Proc(
void *instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
TcpState *statePtr = (TcpState *)instanceData;
int readError = 0;
int writeError = 0;
/*
* Shutdown the OS socket handle.
*/
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
return TcpCloseProc(instanceData, interp);
}
/*
* Single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
* TCL_WRITABLE so this should never be called for a server socket.
*/
if ((flags & TCL_CLOSE_READ)
&& (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) {
Tcl_WinConvertError((DWORD) WSAGetLastError());
readError = Tcl_GetErrno();
}
if ((flags & TCL_CLOSE_WRITE)
&& (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR)) {
Tcl_WinConvertError((DWORD) WSAGetLastError());
writeError = Tcl_GetErrno();
}
return (readError != 0) ? readError : writeError;
}
/*
|
| ︙ | ︙ | |||
1162 1163 1164 1165 1166 1167 1168 | * Changes attributes of the socket at the system level. * *---------------------------------------------------------------------- */ static int TcpSetOptionProc( | | | 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 |
* Changes attributes of the socket at the system level.
*
*----------------------------------------------------------------------
*/
static int
TcpSetOptionProc(
void *instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to set. */
const char *value) /* New value for option. */
{
TcpState *statePtr = (TcpState *)instanceData;
SOCKET sock;
size_t len = 0;
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
if ((len > 1) && (optionName[1] == 'n') &&
| | | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 |
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
if ((len > 1) && (optionName[1] == 'n') &&
(strncmp(optionName, "-nodelay", len) == 0)) {
BOOL boolVar;
int rtn;
if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
return TCL_ERROR;
}
rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY,
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 | * None. * *---------------------------------------------------------------------- */ static int TcpGetOptionProc( | | > > > < | | > | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TcpGetOptionProc(
void *instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
* values. */
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
TcpState *statePtr = (TcpState *)instanceData;
char host[NI_MAXHOST], port[NI_MAXSERV];
SOCKET sock;
size_t len = 0;
int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
#define HAVE_OPTION(option) \
((len > 1) && (optionName[1] == option[1]) && \
(strncmp(optionName, option, len) == 0))
/*
* Go one step in async connect
*
* If any error is thrown save it as background error to report eventually
* below.
*/
if (!GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)) {
WaitForConnect(statePtr, NULL);
}
sock = statePtr->sockets->fd;
if (optionName != NULL) {
len = strlen(optionName);
}
if (HAVE_OPTION("-error")) {
/*
* Do not return any errors if async connect is running.
*/
if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
/*
* In case of a failed async connect, eventually report the
* connect error only once. Do not report the system error,
* as this comes again and again.
*/
if (statePtr->connectError != 0) {
Tcl_DStringAppend(dsPtr,
Tcl_ErrnoMsg(statePtr->connectError),
TCL_INDEX_NONE);
statePtr->connectError = 0;
}
} else {
/*
* Report an eventual last error of the socket system.
*/
|
| ︙ | ︙ | |||
1327 1328 1329 1330 1331 1332 1333 |
/*
* Return error message.
*/
if (err) {
Tcl_WinConvertError(err);
| | > < | | | < | 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 |
/*
* Return error message.
*/
if (err) {
Tcl_WinConvertError(err);
Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()),
TCL_INDEX_NONE);
}
}
}
return TCL_OK;
}
if (HAVE_OPTION("-connecting")) {
Tcl_DStringAppend(dsPtr,
GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)
? "1" : "0", TCL_INDEX_NONE);
return TCL_OK;
}
if (interp != NULL
&& Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
reverseDNS = NI_NUMERICHOST;
}
if ((len == 0) || HAVE_OPTION("-peername")) {
address peername;
socklen_t size = sizeof(peername);
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* In async connect output an empty string
*/
|
| ︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 |
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
}
| | < | 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 |
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
}
if ((len == 0) || HAVE_OPTION("-sockname")) {
TcpFdList *fds;
address sockname;
socklen_t size;
int found = 0;
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-sockname");
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get sockname: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
| | < | < | 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get sockname: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
if ((len == 0) || HAVE_OPTION("-keepalive")) {
int optlen;
BOOL opt = FALSE;
if (len == 0) {
sock = statePtr->sockets->fd;
Tcl_DStringAppendElement(dsPtr, "-keepalive");
}
optlen = sizeof(BOOL);
getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen);
Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0");
if (len > 0) {
return TCL_OK;
}
}
if ((len == 0) || HAVE_OPTION("-nodelay")) {
int optlen;
BOOL opt = FALSE;
if (len == 0) {
sock = statePtr->sockets->fd;
Tcl_DStringAppendElement(dsPtr, "-nodelay");
}
|
| ︙ | ︙ | |||
1541 1542 1543 1544 1545 1546 1547 | * already true. * *---------------------------------------------------------------------- */ static void TcpWatchProc( | | | 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 |
* already true.
*
*----------------------------------------------------------------------
*/
static void
TcpWatchProc(
void *instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *)instanceData;
/*
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 | * None. * *---------------------------------------------------------------------- */ static int TcpGetHandleProc( | | | | 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TcpGetHandleProc(
void *instanceData, /* The socket state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
*handlePtr = INT2PTR(statePtr->sockets->fd);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1619 1620 1621 1622 1623 1624 1625 | * This might be called in 3 circumstances: * - By a regular socket command * - By the event handler to continue an asynchronously connect * - By a blocking socket function (gets/puts) to terminate the * connect synchronously * * Results: | | | | | 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 | * This might be called in 3 circumstances: * - By a regular socket command * - By the event handler to continue an asynchronously connect * - By a blocking socket function (gets/puts) to terminate the * connect synchronously * * Results: * TCL_OK, if the socket was successfully connected or an asynchronous * connection is in progress. If an error occurs, TCL_ERROR is returned * and an error message is left in interp. * * Side effects: * Opens a socket. * * Remarks: * A single host name may resolve to more than one IP address, e.g. for * an IPv4/IPv6 dual stack host. For handling asynchronously connecting |
| ︙ | ︙ | |||
1648 1649 1650 1651 1652 1653 1654 |
static int
TcpConnect(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
TcpState *statePtr)
{
DWORD error;
int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
| | | | | | | > | | | | | | 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 |
static int
TcpConnect(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
TcpState *statePtr)
{
DWORD error;
int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
/* We are started with async connect and the
* connect notification was not yet
* received. */
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
/* We were called by the event procedure and
* continue our loop. */
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
statePtr->addr = statePtr->addr->ai_next) {
for (statePtr->myaddr = statePtr->myaddrlist;
statePtr->myaddr != NULL;
statePtr->myaddr = statePtr->myaddr->ai_next) {
/*
* No need to try combinations of local and remote addresses
* of different families.
*/
if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
continue;
}
/*
* Close the socket if it is still open from the last unsuccessful
* iteration.
*/
if (statePtr->sockets->fd != INVALID_SOCKET) {
closesocket(statePtr->sockets->fd);
}
/*
* Get statePtr lock.
|
| ︙ | ︙ | |||
1726 1727 1728 1729 1730 1731 1732 | SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); /* * Set kernel space buffering */ | | | 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 | SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); /* * Set kernel space buffering */ TclSockMinimumBuffers((void *)statePtr->sockets->fd, TCP_BUFFER_SIZE); /* * Try to bind to a local port. */ if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, |
| ︙ | ︙ | |||
1990 1991 1992 1993 1994 1995 1996 |
TclInitSockets();
/*
* Do the name lookups for the local and remote addresses.
*/
if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
| | | | | | | | | | | | 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 |
TclInitSockets();
/*
* Do the name lookups for the local and remote addresses.
*/
if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
|| !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
&errorMsg)) {
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", errorMsg));
}
return NULL;
}
statePtr = NewSocketInfo(INVALID_SOCKET);
statePtr->addrlist = addrlist;
statePtr->myaddrlist = myaddrlist;
if (async) {
SET_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
|
| ︙ | ︙ | |||
2052 2053 2054 2055 2056 2057 2058 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
| < < < < > | | > | 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 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
TclInitSockets();
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
/*
* Set kernel space buffering and non-blocking.
*/
TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE);
TcpState *statePtr = NewSocketInfo((SOCKET) sock);
/*
* Start watching for read/write events on the socket.
*/
statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
SendSelectMessage(tsdPtr, SELECT, statePtr);
char channelName[SOCK_CHAN_LENGTH];
TclWinGenerateChannelName(channelName, "sock", statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, (TCL_READABLE | TCL_WRITABLE));
Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf");
return statePtr->channel;
}
|
| ︙ | ︙ | |||
2105 2106 2107 2108 2109 2110 2111 |
Tcl_Channel
Tcl_OpenTcpServerEx(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
| | | | 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 |
Tcl_Channel
Tcl_OpenTcpServerEx(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
int backlog, /* Length of OS listen backlog queue, or -1
* for default. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
void *acceptProcData) /* Data for the callback. */
{
SOCKET sock = INVALID_SOCKET;
unsigned short chosenport = 0;
|
| ︙ | ︙ | |||
2140 2141 2142 2143 2144 2145 2146 |
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
&errorMsg)) {
goto error;
}
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
| | | 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 |
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
&errorMsg)) {
goto error;
}
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
addrPtr->ai_protocol);
if (sock == INVALID_SOCKET) {
Tcl_WinConvertError((DWORD) WSAGetLastError());
continue;
}
/*
* Win-NT has a misfeature that sockets are inherited in child
|
| ︙ | ︙ | |||
2217 2218 2219 2220 2221 2222 2223 | /* * Set the maximum number of pending connect requests to the max * value allowed on each platform (Win32 and Win32s may be * different, and there may be differences between TCP/IP stacks). */ | | | | | 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 |
/*
* Set the maximum number of pending connect requests to the max
* value allowed on each platform (Win32 and Win32s may be
* different, and there may be differences between TCP/IP stacks).
*/
if (backlog < 0) {
backlog = SOMAXCONN;
}
if (listen(sock, backlog) == SOCKET_ERROR) {
Tcl_WinConvertError((DWORD) WSAGetLastError());
closesocket(sock);
continue;
}
if (statePtr == NULL) {
|
| ︙ | ︙ | |||
2243 2244 2245 2246 2247 2248 2249 |
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
| | > | | | 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 |
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
TclWinGenerateChannelName(channelName, "sock", statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
/*
* Set up the select mask for connection request events.
*/
statePtr->selectEvents = FD_ACCEPT;
/*
* Register for interest in events in the select mask. Note that this
* automatically places the socket into non-blocking mode.
*/
ioctlsocket(sock, (long) FIONBIO, &flag);
SendSelectMessage(tsdPtr, SELECT, statePtr);
if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "")
== TCL_ERROR) {
Tcl_CloseEx(NULL, statePtr->channel, 0);
return NULL;
}
return statePtr->channel;
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s",
(errorMsg ? errorMsg : Tcl_PosixError(interp))));
}
if (sock != INVALID_SOCKET) {
closesocket(sock);
}
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 |
address addr) /* Address of new socket. */
{
TcpState *newInfoPtr;
TcpState *statePtr = fds->statePtr;
int len = sizeof(addr);
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
| | > | 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 |
address addr) /* Address of new socket. */
{
TcpState *newInfoPtr;
TcpState *statePtr = fds->statePtr;
int len = sizeof(addr);
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
/*
* Win-NT has a misfeature that sockets are inherited in child processes
* by default. Turn off the inherit bit.
*/
SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);
|
| ︙ | ︙ | |||
2352 2353 2354 2355 2356 2357 2358 |
/*
* Invoke the accept callback function.
*/
if (statePtr->acceptProc != NULL) {
getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
| | | | 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 |
/*
* Invoke the accept callback function.
*/
if (statePtr->acceptProc != NULL) {
getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
statePtr->acceptProc(statePtr->acceptProcData, newInfoPtr->channel,
host, atoi(port));
}
}
/*
*----------------------------------------------------------------------
*
* InitSocketWindowClass --
|
| ︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 |
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
if (GOT_BITS(statePtr->readyEvents,
statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
| | | 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 |
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
if (GOT_BITS(statePtr->readyEvents,
statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
&& !GOT_BITS(statePtr->flags, SOCKET_PENDING)) {
SET_BITS(statePtr->flags, SOCKET_PENDING);
evPtr = (SocketEvent *)Tcl_Alloc(sizeof(SocketEvent));
evPtr->header.proc = SocketEventProc;
evPtr->socket = statePtr->sockets->fd;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
|
| ︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 |
}
/*
* Discard events that have gone stale.
*/
if (!statePtr) {
| | | 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 |
}
/*
* Discard events that have gone stale.
*/
if (!statePtr) {
SetEvent(tsdPtr->socketListLock);
return 1;
}
/*
* Clear flag that (this) event is pending
*/
|
| ︙ | ︙ | |||
2837 2838 2839 2840 2841 2842 2843 |
* Populate new FD.
*/
fds->fd = socket;
fds->statePtr = statePtr;
fds->next = NULL;
}
| | < | > | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 |
* Populate new FD.
*/
fds->fd = socket;
fds->statePtr = statePtr;
fds->next = NULL;
}
/*
*----------------------------------------------------------------------
*
* NewSocketInfo --
*
* This function allocates and initializes a new TcpState structure.
*
* Results:
* Returns a newly allocated TcpState.
*
* Side effects:
* None, except for allocation of memory.
*
*----------------------------------------------------------------------
*/
static TcpState *
NewSocketInfo(
SOCKET socket)
{
TcpState *statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
/*
* TIP #218. Removed the code inserting the new structure into the global
|
| ︙ | ︙ | |||
2893 2894 2895 2896 2897 2898 2899 | * Processes socket events off the system queue. * *---------------------------------------------------------------------- */ static int WaitForSocketEvent( | | | < | > | 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 |
* Processes socket events off the system queue.
*
*----------------------------------------------------------------------
*/
static int
WaitForSocketEvent(
TcpState *statePtr, /* Information about this socket. */
int events, /* Events to look for. May be one of
* FD_READ or FD_WRITE. */
int *errorCodePtr) /* Where to store errors? */
{
int result = 1;
int oldMode;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
/*
* Be sure to disable event servicing so we are truly modal.
*/
oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
|
| ︙ | ︙ | |||
3028 3029 3030 3031 3032 3033 3034 |
* This releases waiters on thread exit in TclpFinalizeSockets()
*/
SetEvent(tsdPtr->readyEvent);
return msg.wParam;
}
| < | 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 |
* This releases waiters on thread exit in TclpFinalizeSockets()
*/
SetEvent(tsdPtr->readyEvent);
return msg.wParam;
}
/*
*----------------------------------------------------------------------
*
* SocketProc --
*
* This function is called when WSAAsyncSelect has been used to register
|
| ︙ | ︙ |
Changes to win/tclWinTest.c.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
| | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be done or wait", (char *)NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
path = NULL;
}
found = GetVolumeInformationA(path, NULL, 0, NULL, NULL, NULL, volType,
VOL_BUF_SIZE);
if (found == 0) {
Tcl_AppendResult(interp, "could not get volume type for \"",
| | | | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
path = NULL;
}
found = GetVolumeInformationA(path, NULL, 0, NULL, NULL, NULL, volType,
VOL_BUF_SIZE);
if (found == 0) {
Tcl_AppendResult(interp, "could not get volume type for \"",
(path?path:""), "\"", (char *)NULL);
Tcl_WinConvertError(GetLastError());
return TCL_ERROR;
}
Tcl_AppendResult(interp, volType, (char *)NULL);
return TCL_OK;
#undef VOL_BUF_SIZE
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
450 451 452 453 454 455 456 |
isDir = (attr & FILE_ATTRIBUTE_DIRECTORY) != 0;
if (!OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hToken)) {
goto done;
}
/* Get process SID */
| | | | | < | | 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 |
isDir = (attr & FILE_ATTRIBUTE_DIRECTORY) != 0;
if (!OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hToken)) {
goto done;
}
/* Get process SID */
if (!GetTokenInformation(hToken, TokenUser, NULL, 0, &dw)
&& GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
pTokenUser = (TOKEN_USER *)Tcl_Alloc(dw);
if (!GetTokenInformation(hToken, TokenUser, pTokenUser, dw, &dw)) {
goto done;
}
aceEntry[nSids].sidLen = GetLengthSid(pTokenUser->User.Sid);
aceEntry[nSids].pSid = (PSID)Tcl_Alloc(aceEntry[nSids].sidLen);
if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid,
pTokenUser->User.Sid)) {
Tcl_Free(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */
goto done;
}
/*
* Always include DACL modify rights so we don't get locked out
*/
aceEntry[nSids].mask = READ_CONTROL | WRITE_DAC | WRITE_OWNER | SYNCHRONIZE |
|
| ︙ | ︙ | |||
502 503 504 505 506 507 508 |
}
pTokenGroup = (TOKEN_PRIMARY_GROUP *)Tcl_Alloc(dw);
if (!GetTokenInformation(hToken, TokenPrimaryGroup, pTokenGroup, dw, &dw)) {
Tcl_Free(pTokenGroup);
goto done;
}
aceEntry[nSids].sidLen = GetLengthSid(pTokenGroup->PrimaryGroup);
| | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 |
}
pTokenGroup = (TOKEN_PRIMARY_GROUP *)Tcl_Alloc(dw);
if (!GetTokenInformation(hToken, TokenPrimaryGroup, pTokenGroup, dw, &dw)) {
Tcl_Free(pTokenGroup);
goto done;
}
aceEntry[nSids].sidLen = GetLengthSid(pTokenGroup->PrimaryGroup);
aceEntry[nSids].pSid = (PSID)Tcl_Alloc(aceEntry[nSids].sidLen);
if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pTokenGroup->PrimaryGroup)) {
Tcl_Free(pTokenGroup);
Tcl_Free(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */
goto done;
}
Tcl_Free(pTokenGroup);
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
if (pmode & 0007) {
/* World permissions */
PSID pWorldSid;
if (!ConvertStringSidToSidA("S-1-1-0", &pWorldSid)) {
goto done;
}
aceEntry[nSids].sidLen = GetLengthSid(pWorldSid);
| | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
if (pmode & 0007) {
/* World permissions */
PSID pWorldSid;
if (!ConvertStringSidToSidA("S-1-1-0", &pWorldSid)) {
goto done;
}
aceEntry[nSids].sidLen = GetLengthSid(pWorldSid);
aceEntry[nSids].pSid = (PSID)Tcl_Alloc(aceEntry[nSids].sidLen);
if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pWorldSid)) {
LocalFree(pWorldSid);
Tcl_Free(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */
goto done;
}
LocalFree(pWorldSid);
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
}
/*
* Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used
* to remove inherited ACL (we need to overwrite the default ACL's in this case)
*/
| | < | < < < < | | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
}
/*
* Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used
* to remove inherited ACL (we need to overwrite the default ACL's in this case)
*/
if (SetNamedSecurityInfoA((LPSTR)nativePath, SE_FILE_OBJECT,
DACL_SECURITY_INFORMATION | PROTECTED_DACL_SECURITY_INFORMATION,
NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
res = 0;
}
done:
if (pTokenUser) {
Tcl_Free(pTokenUser);
}
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 |
if (res != 0) {
return res;
}
/* Run normal chmod command */
return chmod(nativePath, pmode);
| < < | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
if (res != 0) {
return res;
}
/* Run normal chmod command */
return chmod(nativePath, pmode);
}
/*
*---------------------------------------------------------------------------
*
* TestchmodCmd --
*
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (TestplatformChmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
| | | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (TestplatformChmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
(char *)NULL);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
}
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to win/tclWinThrd.c.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | * of Tcl as a whole. */ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
* of Tcl as a whole.
*/
static CRITICAL_SECTION initLock;
/*
* allocLock is used by Tcl's version of malloc for synchronization. For
* obvious reasons, cannot use any dynamically allocated storage.
*/
#if TCL_THREADS
static struct Tcl_Mutex_ {
CRITICAL_SECTION crit;
} allocLock;
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
/*
* The per-thread event and queue pointers.
*/
#if TCL_THREADS
typedef struct ThreadSpecificData {
| | | > > | | | | < | < < < | | | | > | | < | 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 |
/*
* The per-thread event and queue pointers.
*/
#if TCL_THREADS
typedef struct ThreadSpecificData {
HANDLE condEvent; /* Per-thread condition event */
struct ThreadSpecificData *nextPtr; /* Queue pointers */
struct ThreadSpecificData *prevPtr;
int flags; /* See ThreadStateFlags below */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif /* TCL_THREADS */
/*
* State bits for the thread.
*/
enum ThreadStateFlags {
WIN_THREAD_UNINIT = 0x0, /* Uninitialized. Must be zero because of the
* way ThreadSpecificData is created. */
WIN_THREAD_RUNNING = 0x1, /* Running, not waiting. */
WIN_THREAD_BLOCKED = 0x2 /* Waiting, or trying to wait. */
};
/*
* The per condition queue pointers and the Mutex used to serialize access to
* the queue.
*/
typedef struct {
CRITICAL_SECTION condLock; /* Lock to serialize queuing on the
* condition. */
ThreadSpecificData *firstPtr; /* Queue pointers */
ThreadSpecificData *lastPtr;
} WinCondition;
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
static DWORD tlsKey;
typedef struct {
Tcl_Mutex tlock;
CRITICAL_SECTION wlock;
} allocMutex;
#endif /* USE_THREAD_ALLOC */
/*
* The per thread data passed from TclpThreadCreate
* to TclWinThreadStart.
*/
typedef struct {
LPTHREAD_START_ROUTINE lpStartAddress;
/* Original startup routine */
LPVOID lpParameter; /* Original startup data */
unsigned int fpControl; /* Floating point control word from the
* main thread */
} WinThread;
/*
*----------------------------------------------------------------------
*
* TclWinThreadStart --
*
* This procedure is the entry point for all new threads created
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
*----------------------------------------------------------------------
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
| | | | | < | 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 |
*----------------------------------------------------------------------
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
void *clientData, /* The one argument to Main(). */
size_t stackSize, /* Size of stack for the new thread. */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
WinThread *winThreadPtr; /* Per-thread startup info */
HANDLE tHandle;
winThreadPtr = (WinThread *)Tcl_Alloc(sizeof(WinThread));
winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc;
winThreadPtr->lpParameter = clientData;
winThreadPtr->fpControl = _controlfp(0, 0);
EnterCriticalSection(&joinLock);
*idPtr = 0; /* must initialize as Tcl_Thread is a pointer and
* on WIN64 sizeof void* != sizeof unsigned */
#if defined(_MSC_VER) || defined(__MSVCRT__)
tHandle = (HANDLE) _beginthreadex(NULL, (unsigned)stackSize,
(Tcl_ThreadCreateProc*) TclWinThreadStart, winThreadPtr,
0, (unsigned *)idPtr);
#else
tHandle = CreateThread(NULL, (DWORD)stackSize,
|
| ︙ | ︙ | |||
288 289 290 291 292 293 294 | * * Side effects: * This procedure terminates the current thread. * *---------------------------------------------------------------------- */ | | | 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 |
*
* Side effects:
* This procedure terminates the current thread.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
TclpThreadExit(
int status)
{
EnterCriticalSection(&joinLock);
TclSignalExitThread(Tcl_GetCurrentThread(), status);
LeaveCriticalSection(&joinLock);
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 | /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for | | | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 | /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for * use by the memory allocator. The allocator must use this lock, because * all other locks are allocated... * * Results: * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and * Tcl_MutexUnlock. * * Side effects: |
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
TclpGlobalLock();
/*
* Double inside global lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
| | | | 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
TclpGlobalLock();
/*
* Double inside global lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
csPtr = (CRITICAL_SECTION *) Tcl_Alloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex) csPtr;
TclRememberMutex(mutexPtr);
}
TclpGlobalUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
EnterCriticalSection(csPtr);
}
|
| ︙ | ︙ | |||
656 657 658 659 660 661 662 |
*----------------------------------------------------------------------
*/
void
Tcl_ConditionWait(
Tcl_Condition *condPtr, /* Really (WinCondition **) */
Tcl_Mutex *mutexPtr, /* Really (CRITICAL_SECTION **) */
| | | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
*----------------------------------------------------------------------
*/
void
Tcl_ConditionWait(
Tcl_Condition *condPtr, /* Really (WinCondition **) */
Tcl_Mutex *mutexPtr, /* Really (CRITICAL_SECTION **) */
const Tcl_Time *timePtr) /* Timeout on waiting period */
{
WinCondition *winCondPtr; /* Per-condition queue head */
CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */
DWORD wtime; /* Windows time value */
int timeout; /* True if we got a timeout */
int doExit = 0; /* True if we need to do exit setup */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
923 924 925 926 927 928 929 |
if (winCondPtr != NULL) {
DeleteCriticalSection(&winCondPtr->condLock);
Tcl_Free(winCondPtr);
*condPtr = NULL;
}
}
| < < < | 920 921 922 923 924 925 926 927 928 929 930 931 932 933 |
if (winCondPtr != NULL) {
DeleteCriticalSection(&winCondPtr->condLock);
Tcl_Free(winCondPtr);
*condPtr = NULL;
}
}
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
Tcl_Mutex *
TclpNewAllocMutex(void)
|
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 |
success = TlsFree(tlsKey);
if (!success) {
Tcl_Panic("TlsFree failed from TclpFreeAllocCache");
}
}
}
#endif /* USE_THREAD_ALLOC */
| < | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 |
success = TlsFree(tlsKey);
if (!success) {
Tcl_Panic("TlsFree failed from TclpFreeAllocCache");
}
}
}
#endif /* USE_THREAD_ALLOC */
void *
TclpThreadCreateKey(void)
{
DWORD *key;
key = (DWORD *)TclpSysAlloc(sizeof *key);
|
| ︙ | ︙ |
Changes to win/tclWinTime.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 |
DWORD calibrationInterv; /* Calibration interval in seconds (start 1
* sec) */
HANDLE calibrationThread; /* Handle to the thread that keeps the virtual
* clock calibrated. */
HANDLE readyEvent; /* System event used to trigger the requesting
* thread when the clock calibration procedure
* is initialized for the first time. */
| | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
DWORD calibrationInterv; /* Calibration interval in seconds (start 1
* sec) */
HANDLE calibrationThread; /* Handle to the thread that keeps the virtual
* clock calibrated. */
HANDLE readyEvent; /* System event used to trigger the requesting
* thread when the clock calibration procedure
* is initialized for the first time. */
HANDLE exitEvent; /* Event to signal out of an exit handler to
* tell the calibration loop to terminate. */
LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance
* counter, that is, the value returned from
* QueryPerformanceFrequency. */
/*
* The following values are used for calculating virtual time. Virtual
* time is always equal to:
|
| ︙ | ︙ | |||
77 78 79 80 81 82 83 |
#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
(LARGE_INTEGER) (long long) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
(LARGE_INTEGER) (long long) 0,
(LARGE_INTEGER) (long long) 0,
(LARGE_INTEGER) (long long) 0,
#else
| | | | | | < | | 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 |
#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
(LARGE_INTEGER) (long long) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
(LARGE_INTEGER) (long long) 0,
(LARGE_INTEGER) (long long) 0,
(LARGE_INTEGER) (long long) 0,
#else
{{0, 0}},
{{0, 0}},
{{0, 0}},
{{0, 0}},
{{0, 0}},
#endif
{ 0 },
{ 0 },
0
};
/*
* Scale to convert wide click values from the TclpGetWideClicks native
* resolution to microsecond resolution and back.
*/
static struct {
int initialized; /* 1 if initialized, 0 otherwise */
int perfCounter; /* 1 if performance counter usable for wide
* clicks */
double microsecsScale; /* Denominator scale between clock / microsecs */
} wideClick = {0, 0, 0.0};
/*
* Declarations for functions defined later in this file.
*/
static void StopCalibration(void *clientData);
static DWORD WINAPI CalibrationThread(LPVOID arg);
static void UpdateTimeEachSecond(void);
static void ResetCounterSamples(unsigned long long fileTime,
long long perfCounter, long long perfFreq);
static long long AccumulateSample(long long perfCounter,
unsigned long long fileTime);
static void NativeScaleTime(Tcl_Time* timebuf,
void *clientData);
static long long NativeGetMicroseconds(void);
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
return (long long)curCounter.QuadPart;
}
/* fallback using microseconds */
wideClick.perfCounter = 0;
wideClick.microsecsScale = 1;
return TclpGetMicroseconds();
} else {
| | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 |
return (long long)curCounter.QuadPart;
}
/* fallback using microseconds */
wideClick.perfCounter = 0;
wideClick.microsecsScale = 1;
return TclpGetMicroseconds();
} else {
return TclpGetMicroseconds();
}
}
/*
*----------------------------------------------------------------------
*
* TclpWideClickInMicrosec --
*
* This procedure return scale to convert wide click values from the
* TclpGetWideClicks native resolution to microsecond resolution
* and back.
*
* Results:
* 1 click in microseconds as double.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
double
TclpWideClickInMicrosec(void)
{
if (!wideClick.initialized) {
(void) TclpGetWideClicks(); /* initialize */
}
return wideClick.microsecsScale;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
867 868 869 870 871 872 873 |
/*
* If calibration still not needed (check for possible time switch)
*/
if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart <
lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) {
| | | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 |
/*
* If calibration still not needed (check for possible time switch)
*/
if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart <
lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) {
/*
* Look again in next one second.
*/
return;
}
QueryPerformanceCounter(&curPerfCounter);
|
| ︙ | ︙ | |||
937 938 939 940 941 942 943 |
* If we've gotten more than a second away from system time, then drifting
* the clock is going to be pretty hopeless. Just let it jump. Otherwise,
* compute the drift frequency and fill in everything.
*/
tdiff = vt0 - curFileTime.QuadPart;
if (tdiff > 10000000 || tdiff < -10000000) {
| | | | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
* If we've gotten more than a second away from system time, then drifting
* the clock is going to be pretty hopeless. Just let it jump. Otherwise,
* compute the drift frequency and fill in everything.
*/
tdiff = vt0 - curFileTime.QuadPart;
if (tdiff > 10000000 || tdiff < -10000000) {
/*
* Jump to current system time, use curent estimated frequency.
*/
vt0 = curFileTime.QuadPart;
} else {
/*
* Calculate new frequency and estimate drift to the next second.
*/
vt1 = 20000000 + curFileTime.QuadPart;
driftFreq = (estFreq * 20000000 / (vt1 - vt0));
/*
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 |
/*
* If drift unavoidable (e. g. we had a time switch), then reset
* it.
*/
vt1 = vt0 - curFileTime.QuadPart;
if (vt1 > 10000000 || vt1 < -10000000) {
| | | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 |
/*
* If drift unavoidable (e. g. we had a time switch), then reset
* it.
*/
vt1 = vt0 - curFileTime.QuadPart;
if (vt1 > 10000000 || vt1 < -10000000) {
/*
* Larger jump resp. shift relative new file-time.
*/
vt0 = curFileTime.QuadPart;
}
}
}
/*
* In lock commit new values to timeInfo (hold lock as short as possible)
*/
|
| ︙ | ︙ |
Changes to win/tclsh.rc.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO | | | | | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
#define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
VS_VERSION_INFO VERSIONINFO
FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
FILEFLAGSMASK 0x3fL
#ifdef DEBUG
FILEFLAGS VS_FF_DEBUG
#else
FILEFLAGS 0x0L
#endif
FILEOS VOS__WINDOWS32
FILETYPE VFT_APP
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "Tclsh Application\0"
VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"
|
| ︙ | ︙ |
Changes to win/tcltest.rc.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO | | | | | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
#define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
VS_VERSION_INFO VERSIONINFO
FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
FILEFLAGSMASK 0x3fL
#ifdef DEBUG
FILEFLAGS VS_FF_DEBUG
#else
FILEFLAGS 0x0L
#endif
FILEOS VOS__WINDOWS32
FILETYPE VFT_APP
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "Tcltest Application\0"
VALUE "OriginalFilename", "tcltest" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"
|
| ︙ | ︙ |
Added win/vctool.bat.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
@echo off
REM Pass /? as argument for usage.
IF DEFINED VCINSTALLDIR goto setup
echo "Not in a Visual Studio command prompt."
exit /B 1
:setup
setlocal
set "tool=%0"
REM Get the current directory
set "currentDir=%CD%"
REM Use FOR command to get the parent directory
for %%I in ("%currentDir%") do set "parentDir=%%~dpI"
REM Remove the trailing backslash
set "parentDir=%parentDir:~0,-1%"
REM Use FOR command again to get the parent of the parent directory
for %%J in ("%parentDir%") do set "grandParentDir=%%~dpJ"
REM Remove the trailing backslash
set "grandParentDir=%grandParentDir:~0,-1%"
REM Use FOR command to extract the last component
for %%I in ("%grandParentDir%") do set "grandParentTail=%%~nxI"
REM Extract the drive letter
for %%I in ("%currentDir%") do set "driveLetter=%%~dI"
set ARCH=%VSCMD_ARG_TGT_ARCH%
if "%TCLINSTALLROOT%" == "" (
set INSTROOT=%driveLetter%\Tcl\%grandParentTail%\%ARCH%
) else (
set INSTROOT=%TCLINSTALLROOT%\%grandParentTail%\%ARCH%
)
REM Parse options
:options
if "%1" == "" goto dobuilds
if "%1" == "/?" goto help
if "%1" == "-?" goto help
if /i "%1" == "/help" goto help
if "%1" == "all" goto all
if "%1" == "shared" goto shared
if "%1" == "static" goto static
if "%1" == "shared_noembed" goto shared_noembed
if "%1" == "static_noembed" goto static_noembed
if "%1" == "compile" goto compile
if "%1" == "test" goto targets
if "%1" == "install" goto targets
if "%1" == "runshell" goto targets
if "%1" == "debug" goto debug
goto help
:debug
set debug=1
shift
goto options
:shared
set shared=1
shift
goto options
:static
set static=1
shift
goto options
:shared_noembed
set shared_noembed=1
shift
goto options
:static_noembed
set static_noembed=1
shift
goto options
:all
set shared=1
set static=1
set shared_noembed=1
set static_noembed=1
shift
goto options
:targets
set TARGETS=%TARGETS% %1
shift
goto options
REM The makefile.vc compilation target is called "release"
:compile
set TARGETS=%TARGETS% release
shift
goto options
:dobuilds
if "%shared%%static%%shared_noembed%%static_noembed%" == "" (
echo At least one of shared, static, shared_noembed, static_noembed, all must be specified.
echo For more help, type "%0 help"
goto error
)
if DEFINED shared (
call :runmake shared
)
if DEFINED shared_noembed (
call :runmake shared-noembed noembed
)
if DEFINED static (
call :runmake static static
)
if DEFINED static_noembed (
call :runmake static-noembed "static,noembed"
)
:done
endlocal
exit /b 0
:error
endlocal
exit /b 1
:: call :runmake dir opts
:runmake
if "%debug%" == "" (
nmake /s /f makefile.vc OUT_DIR=%currentDir%\vc-%ARCH%-%1 TMP_DIR=%currentDir%\vc-%ARCH%-%1\objs OPTS=pdbs,%2 INSTALLDIR=%INSTROOT%-%1 %TARGETS% && goto error
) else (
nmake /s /f makefile.vc OUT_DIR=%currentDir%\vc-%ARCH%-%1-debug TMP_DIR=%currentDir%\vc-%ARCH%-%1-debug\objs OPTS=pdbs,%2 cdebug="-Zi -Od" INSTALLDIR=%INSTROOT%-%1-debug %TARGETS% && goto error
)
goto eof
:help
echo.
echo Usage: %0 arg ...
echo.
echo where each arg may be either a build config or a target or "debug".
echo.
echo Configs: shared, static, shared_noembed, static_noembed, all
echo Targets: compile (default), test, install
echo.
echo Multiple configs and targets may be specified and intermixed.
echo At least one config must be specified. If no targets specified,
echo default is compile. If multiple targets are present, they
echo are built in specified order.
echo.
echo If "debug" is supplied as an argument, the build has optimizations
echo disabled and full debug information.
echo.
echo If environment variable TCLINSTALLROOT is defined, install target
echo will be subdirectory under it named after the grandparent of the
echo current directory. TCLINSTALLROOT defaults to the X:\Tcl where
echo X is the current drive.
echo.
echo For example, if the current directory C:\src\core-8-branch\tcl\win,
echo install directories will be echo under c:\Tcl\core-8-branch\ as
echo x64-shared, x64-static etc. or x64-shared-debug etc. if "debug" passed.
echo.
echo Examples:
echo %tool% shared (Builds default "shared" config)
echo %tool% shared test (Tests shared build)
echo %tool% static compile test (Builds and tests static build)
echo %tool% all debug (Build debug versions of all configs)
echo %tool% all compile install debug (Builds and installs all configs)
echo %tool% shared static shared_noembed (Builds three configs)
goto done
|